Return to common0.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/common0.l, revision 1.1

1.1     ! root        1: (setq rcs-common0-
        !             2:    "$Header: common0.l,v 1.3 83/09/07 08:12:49 jkf Exp $")
        !             3: 
        !             4: ;;
        !             5: ;;  common0.l                          -[Sun Sep  4 13:44:22 1983 by jkf]-
        !             6: ;;
        !             7: ;;   Functions which are required to execute the low level lisp macros
        !             8: ;; and functions.
        !             9: ;;
        !            10: ;;   This is the first file of functions read in when building a lisp.
        !            11: ;; If this lisp is to run interpretedly, then we must not use anything
        !            12: ;; which hasn't be defined in the C lisp kernel, except ';' which is
        !            13: ;; defined as the comment character before reading this file.
        !            14: ;; We cannot use defmacro, the backquote or the # macro.
        !            15: ;;
        !            16: ;;   This file should be as short as possible since it must be written in
        !            17: ;; a rather primitive way.
        !            18: ;;
        !            19: 
        !            20: ;--- declare : ignore whatever is given, this info is for the compiler
        !            21: ;
        !            22: (def declare (nlambda (x) nil))
        !            23: 
        !            24: (declare (macros t))
        !            25: 
        !            26: ;--- memq - arg : (probably a symbol)
        !            27: ;        - lis : list
        !            28: ; returns part of lis beginning with arg if arg is in lis
        !            29: ;      
        !            30: (def memq
        !            31:   (lambda ($a$ $l$)
        !            32:          (do ((ll $l$ (cdr ll)))
        !            33:              ((null ll) nil)
        !            34:              (cond ((eq $a$ (car ll)) (return ll))))))
        !            35: 
        !            36: ;--- def :: define a function
        !            37: ; This superceeds franz's definition.
        !            38: ; It does more error checking and it does lambda conversion
        !            39: ;
        !            40: (def def
        !            41:    (nlambda (l)
        !            42:      ((lambda (name argl)
        !            43:        (cond ((and (symbolp (setq name (car l)))
        !            44:                    (dtpr (cadr l))
        !            45:                    (null (cddr l))
        !            46:                    (memq (caadr l) '(lambda nlambda lexpr macro)))
        !            47:               ; make sure lambda list is nil or a dtpr
        !            48:               (setq l (cadr l))  ; l points to (lambda (argl) ...)
        !            49:               (cond ((null (setq argl (cadr l))))      ; nil check
        !            50:                     ((dtpr (cadr l))                   ; dtpr
        !            51:                      (cond ((and (eq (car l) 'lambda)
        !            52:                                  (or (memq '&aux argl)
        !            53:                                      (memq '&optional argl)
        !            54:                                      (memq '&rest argl)
        !            55:                                      (memq '&body argl)))
        !            56:                             ; must lambda convert
        !            57:                             (setq l (lambdacvt (cdr l))))))
        !            58:                     (t (error "def: bad lambda list of form in " l)))
        !            59:               (putd name l)
        !            60:               name)
        !            61:              (t (error "def: bad form " l))))
        !            62:       nil nil)))
        !            63:                             
        !            64: 
        !            65: ;--- defun
        !            66: ; maclisp style function defintion
        !            67: ;
        !            68: (def defun
        !            69:    (macro (l)
        !            70:       (prog (name type arglist body specind specnam)
        !            71:         (setq name (cadr l) l (cddr l))
        !            72:         (cond ((dtpr name)
        !            73:                (cond ((memq (cadr name) '(macro expr fexpr lexpr))
        !            74:                       (setq l (cons (cadr name) l)
        !            75:                             name (car name)))
        !            76:                      (t (setq specnam (car name)
        !            77:                               specind (cadr name)
        !            78:                               name (concat (gensym) "::" specnam))))))
        !            79:         (cond ((null (car l)) (setq type 'lambda))
        !            80:               ((eq 'fexpr (car l)) (setq type 'nlambda l (cdr l)))
        !            81:               ((eq 'expr (car l))  (setq type 'lambda l (cdr l)))
        !            82:               ((eq 'macro (car l)) (setq type 'macro l (cdr l)))
        !            83:               ((atom (car l))
        !            84:                (setq type 'lexpr
        !            85:                      l (nconc (list (list (car l)))
        !            86:                               (cdr l))))
        !            87:               (t (setq type 'lambda)))
        !            88:         (setq body (list 'def name (cons type l)))
        !            89:         (cond (specnam
        !            90:                  (return (list 'progn ''compile
        !            91:                                body
        !            92:                                (list 'putprop
        !            93:                                      (list 'quote specnam)
        !            94:                                      (list 'getd
        !            95:                                            (list 'quote name))
        !            96:                                      (list 'quote specind)))))
        !            97:               (t (return body))))))
        !            98: 
        !            99: 
        !           100: ;--- error : print error message and cause an error
        !           101: ;  call is usually (error "string" value)
        !           102: ;
        !           103: (def error
        !           104:    ;; form: (error arg1 ...)
        !           105:    ;; concat all args together, with spaces between them
        !           106:    ;; and cause an error to be signaled
        !           107:   (lexpr (n)
        !           108:         (do ((i n (1- i))
        !           109:              (mesg ""))
        !           110:             ((eq i 0) (err-with-message mesg))
        !           111:             (setq mesg (concat
        !           112:                           (cond ((atom (arg i)) (arg i))
        !           113:                                 (t (implode (exploden (arg i)))))
        !           114:                           " " mesg)))))
        !           115: 
        !           116: (def err
        !           117:    ;; (err value [junk])
        !           118:    ;; This is here for maclisp compatibility.  junk should be nil,
        !           119:    ;; but we don't verify.
        !           120:    ;; The value is both to be printed and to be returned from the
        !           121:    ;; errset.  'err-with-message' should be used for new code
        !           122:    (lexpr (n)
        !           123:          (cond ((eq n 0)
        !           124:                 (err-with-message "call to err"))
        !           125:                ((or (eq n 1) (eq n 2))
        !           126:                 (err-with-message (arg 1) (arg 1)))
        !           127:                (t (error "wrong number of args to err:" n)))))
        !           128: 
        !           129: 
        !           130: ;--- append : append two or more lists
        !           131: ; the result will be a copy of all but the last list
        !           132: ;
        !           133: (declare (localf append2args))         
        !           134: 
        !           135: (def append
        !           136:   (lexpr (nargs)
        !           137:         (cond ((eq nargs 2) (append2args (arg 1) (arg 2)))
        !           138:               ((zerop nargs) nil)
        !           139:               (t (do ((i (1- nargs) (1- i))
        !           140:                       (res (arg nargs)))
        !           141:                      ((zerop i) res)
        !           142:                      (setq res (append2args (arg i) res)))))))
        !           143: 
        !           144: ;--- append2args : append just two args
        !           145: ; a version of append which only works on 2 arguments
        !           146: ;
        !           147: (def append2args 
        !           148:   (lambda (x y)
        !           149:          (prog (l l*)
        !           150:                (cond ((null x) (return y))
        !           151:                      ((atom x) (error "Non-list to append:" x)))
        !           152:                (setq l* (setq l (cons (car x) nil)))
        !           153:        loop    (cond ((atom x) (error "Non-list to append:" x))
        !           154:                      ((setq x (cdr x))
        !           155:                       (setq l* (cdr (rplacd l* (cons (car x) nil))))
        !           156:                       (go loop)))
        !           157:                (rplacd l* y)
        !           158:                (return l))))
        !           159: 
        !           160: ;--- append1 : add object to end of list
        !           161: ; adds element y to then end of a copy of list x
        !           162: ;
        !           163: (def append1 (lambda (x y) (append x (list y))))
        !           164: 
        !           165: ;--- assoc - x : lispval
        !           166: ;         - l : list
        !           167: ;      l is a list of lists. The list is examined and the first
        !           168: ;      sublist whose car equals x is returned.
        !           169: ;
        !           170: (def assoc
        !           171:   (lambda (val alist)
        !           172:          (do ((al alist (cdr al)))
        !           173:              ((null al) nil)
        !           174:              (cond ((null (car al)))
        !           175:                    ((not (dtpr (car al)))
        !           176:                     (error "bad arg to assoc" al))
        !           177:                    ((equal val (caar al)) (return (car al)))))))
        !           178: 
        !           179: ;--- rassq : like assq but look at the cdr instead of the car
        !           180: ;
        !           181: (def rassq
        !           182:    (lambda (form list)
        !           183:       (cond ((null list) nil)
        !           184:            ((not (dtpr list))
        !           185:             (error "rassq: illegal second argument: " list))
        !           186:            (t (do ((ll list (cdr ll)))
        !           187:                   ((null ll) nil)
        !           188:                   (cond ((eq form (cdar ll)) (return (car ll)))))))))
        !           189: ;--- concatl - l : list of atoms
        !           190: ;      returns the list of atoms concatentated
        !           191: ;
        !           192: (def concatl
        !           193:  (lambda (x) (apply 'concat x)))
        !           194: 
        !           195: ;--- length - l : list
        !           196: ;      returns the number of elements in the list.
        !           197: ;
        !           198: (def length
        !           199:    (lambda ($l$)
        !           200:       (cond ((and $l$ (not (dtpr $l$)))
        !           201:             (error "length: non list argument: " $l$))
        !           202:            (t (cond ((null $l$) 0)
        !           203:                     (t (do ((ll (cdr $l$)  (cdr ll))
        !           204:                             (i 1 (1+ i)))
        !           205:                            ((null ll) i))))))))
        !           206: 
        !           207: ;--- memq - arg : (probably a symbol)
        !           208: ;        - lis : list
        !           209: ; returns part of lis beginning with arg if arg is in lis
        !           210: ;      
        !           211: (def memq
        !           212:   (lambda ($a$ $l$)
        !           213:          (do ((ll $l$ (cdr ll)))
        !           214:              ((null ll) nil)
        !           215:              (cond ((eq $a$ (car ll)) (return ll))))))
        !           216: 
        !           217: ;--- nconc - x1 x2 ...: lists
        !           218: ;      The cdr of the last cons cell of xi is set to xi+1.  This is the
        !           219: ;      structure modification version of append
        !           220: ;
        !           221: 
        !           222: (def nconc 
        !           223:   (lexpr (nargs) 
        !           224:         (cond ((eq nargs '2) 
        !           225:                (cond ((null (arg 1)) (arg 2))
        !           226:                      (t (do ((tmp (arg 1) (cdr tmp)))
        !           227:                             ((null (cdr tmp)) 
        !           228:                              (rplacd tmp (arg 2))
        !           229:                              (arg 1))))))
        !           230:               ((zerop nargs) nil)
        !           231:               (t (do ((i 1 nxt)
        !           232:                       (nxt 2 (1+ nxt))
        !           233:                       (res (cons nil (arg 1)))) 
        !           234:                      ((eq i nargs) (cdr res))
        !           235:                      (cond ((arg i) (rplacd (last (arg i)) (arg nxt)))
        !           236:                            (t (rplacd (last res) (arg nxt)))))))))
        !           237: 
        !           238: 
        !           239: 
        !           240: (declare (localf nreverse1))   ; quick fcn shared by nreverse and nreconc
        !           241: 
        !           242: ;--- nreconc :: nreverse and nconc
        !           243: ; (nreconc list elemt) is equiv to (nconc (nreverse list) element)
        !           244: ;
        !           245: (defun nreconc (list element)
        !           246:   (cond ((null list) element)
        !           247:        (t (nreverse1 list element))))
        !           248: 
        !           249: ;--- nreverse - l : list
        !           250: ;      reverse the list in place
        !           251: ;
        !           252: 
        !           253: (defun nreverse (x)
        !           254:   (cond ((null x) x)
        !           255:        (t (nreverse1 x nil))))
        !           256: 
        !           257: 
        !           258: ;--- nreverse1
        !           259: ;  common local function to nreconc and nreverse.  [This can just be
        !           260: ; nreconc when I get local global functions allow in the compiler -jkf]
        !           261: ;
        !           262: (defun nreverse1 (x ele)
        !           263:   (prog (nxt)
        !           264:   loop
        !           265:        (setq nxt (cdr x))
        !           266:        (rplacd x ele)
        !           267:        (setq ele x)
        !           268:        (cond (nxt (setq x nxt) (go loop)))
        !           269:        (return x)))
        !           270: 
        !           271: ;--- liszt-declare :: this is defined in the compiler
        !           272: ; we give it a null definition in the interpreter
        !           273: ;
        !           274: (def liszt-declare (nlambda (x) nil))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.