Return to macros.l CVS log

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

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

1.1     ! root        1: (setq rcs-macros-
        !             2:    "$Header: macros.l,v 1.4 83/09/12 15:24:08 layer Exp $")
        !             3: 
        !             4: ;; macros.l                            -[Mon Aug 15 10:41:25 1983 by jkf]-
        !             5: ;;
        !             6: ;;  The file contains the common macros for Franz lisp.
        !             7: ;; contents:
        !             8: ;;     defmacro
        !             9: ;;     setf
        !            10: ;;     defsetf
        !            11: ;;     push
        !            12: ;;     pop
        !            13: ;;     let
        !            14: ;;     let*
        !            15: ;;     caseq
        !            16: ;;     listify
        !            17: ;;     include-if
        !            18: ;;     includef-if
        !            19: ;;     defvar
        !            20: 
        !            21: 
        !            22: (declare (macros t))
        !            23: 
        !            24: ;; defmacro
        !            25: (declare (special defmacrooptlist protect-list protect-evform))
        !            26: 
        !            27: ;--- defmacro - name - name of macro being defined
        !            28: ;            - pattrn - formal arguments plus other fun stuff
        !            29: ;            - body   - body of the macro
        !            30: ; This is an intellegent macro creator.  The pattern may contain
        !            31: ; symbols which are formal paramters, lists which show how the
        !            32: ; actual paramters will appear in the args, and these key words
        !            33: ;  &rest name  - the rest of the args (or nil if there are no other args)
        !            34: ;               is bound to name
        !            35: ;  &optional name - bind the next arg to name if it exists, otherwise
        !            36: ;                  bind it to nil
        !            37: ;  &optional (name init) - bind the next arg to name if it exists, otherwise
        !            38: ;                  bind it to init evaluted. (the evaluation is done left
        !            39: ;                  to right for optional forms)
        !            40: ;  &optional (name init given) - bind the next arg to name and given to t
        !            41: ;                  if the arg exists, else bind name to the value of
        !            42: ;                  init and given to nil.
        !            43: ;  &aux name
        !            44: ;  &aux (name init)
        !            45: ;
        !            46: ; Method of operation:
        !            47: ;  the list returned from defmcrosrc has the form ((cxxr name) ...)
        !            48: ;      where cxxr is the loc of the macro arg and name is it formal name
        !            49: ;  defmcrooptlist has the form ((initv cxxr name) ...)
        !            50: ; which is use for &optional args with an initial value.
        !            51: ;  here cxxr looks like cdd..dr which will test of the arg exists.
        !            52: ;
        !            53: ; the variable defmacro-for-compiling determines if the defmacro forms
        !            54: ; will be compiled. If it is t, then we return (progn 'compile (def xx..))
        !            55: ; to insure that it is compiled
        !            56: ;
        !            57: (declare (special defmacro-for-compiling))
        !            58: (cond ((null (boundp 'defmacro-for-compiling))   ; insure it has a value
        !            59:        (setq defmacro-for-compiling nil)))
        !            60: 
        !            61: (def defmacro
        !            62:   (macro (args)
        !            63:     ((lambda 
        !            64:        (tmp tmp2 defmacrooptlist body protect-evform protect-list gutz)
        !            65:        (setq tmp (defmcrosrch (caddr args) '(d r) nil)
        !            66:             body
        !            67:             `(def ,(cadr args)
        !            68:                   (macro (defmacroarg)
        !            69:                     ((lambda ,(mapcar 'cdr tmp)
        !            70:                              ,@(mapcar 
        !            71:                                   '(lambda (arg)
        !            72:                                      `(cond ((setq ,(caddr arg)
        !            73:                                                    (,(cadr arg) 
        !            74:                                                      defmacroarg))
        !            75:                                              ,@(cond ((setq tmp2 (cadddr arg))
        !            76:                                                       `((setq ,tmp2 t))))
        !            77:                                              (setq ,(caddr arg)
        !            78:                                                    (car ,(caddr arg))))
        !            79:                                             (t (setq ,(caddr arg)
        !            80:                                                      ,(car arg)))))
        !            81:                                        defmacrooptlist)
        !            82:                              ,@(cond (protect-evform 
        !            83:                                       (setq gutz 
        !            84:                                             (eval `((lambda ,(mapcar 'cdr tmp)
        !            85:                                                             ,@(cdddr args))
        !            86:                                                     ,@(mapcar
        !            87:                                                        '(lambda (x) `',(cdr x))
        !            88:                                                        tmp))))
        !            89:                                       (ncons 
        !            90:                                        `(cond (,protect-evform
        !            91:                                                      (copy
        !            92:                                                         `((lambda ,',(mapcar 'cdr tmp)
        !            93:                                                              ,',gutz)
        !            94:                                                           ,,@(mapcar 'cdr tmp))))
        !            95:                                               (t ,@(cdddr args)))))
        !            96:                                      (t (cdddr args))))
        !            97:                      ,@(mapcar '(lambda (arg) 
        !            98:                                         (cond ((dtpr (car arg))
        !            99:                                                (caar arg))
        !           100:                                               ((car arg)
        !           101:                                                `(,(car arg) defmacroarg))))
        !           102:                               tmp)))))
        !           103:       (cond (defmacro-for-compiling `(progn 'compile ,body))
        !           104:            (t body)))
        !           105: 
        !           106:      nil nil nil nil nil nil nil)))
        !           107: 
        !           108: (def defmcrosrch
        !           109:   (lambda (pat form sofar)
        !           110:          (cond ((null pat) sofar)
        !           111:                ((atom pat) (cons (cons (concatl `(c ,@form)) pat)
        !           112:                                  sofar))
        !           113:                ((memq (car pat) '(&rest &body))
        !           114:                 (append (defmcrosrch (cadr pat) form nil)
        !           115:                         (defmcrosrch (cddr pat) form sofar)))
        !           116:                ((eq (car pat) '&optional)
        !           117:                 (defmcrooption (cdr pat) form sofar))
        !           118:                ((eq (car pat) '&protect)
        !           119:                 (setq protect-list (cond ((atom (cadr pat))
        !           120:                                           (ncons (cadr pat)))
        !           121:                                          (t (cadr pat)))
        !           122:                       protect-evform (cons 'or (mapcar '(lambda (x)
        !           123:                                                                 `(dtpr ,x))
        !           124:                                                        protect-list)))
        !           125:                 (defmcrosrch (cddr pat) form sofar))
        !           126:                ((eq (car pat) '&aux)
        !           127:                 (mapcar '(lambda (frm)
        !           128:                                  (cond ((atom frm) `((nil) . ,frm))
        !           129:                                        (t `((,(cadr frm)) . ,(car frm)))))
        !           130:                         (cdr pat)))
        !           131:                (t (append (defmcrosrch (car pat) (cons 'a form) nil)
        !           132:                           (defmcrosrch (cdr pat) (cons 'd form) sofar))))))
        !           133: 
        !           134: (def defmcrooption
        !           135:   (lambda (pat form sofar)
        !           136:     ((lambda (tmp tmp2)
        !           137:          (cond ((null pat) sofar)
        !           138:                ((memq (car pat) '(&rest &body))
        !           139:                 (defmcrosrch (cadr pat) form sofar))
        !           140:                (t (cond ((atom (car pat))
        !           141:                          (setq tmp (car pat)))
        !           142:                         (t (setq tmp (caar pat))
        !           143:                            (setq defmacrooptlist 
        !           144:                                  `((,(cadar pat) 
        !           145:                                        ,(concatl `(c ,@form))
        !           146:                                        ,tmp
        !           147:                                        ,(setq tmp2 (caddar pat)))
        !           148:                                    . ,defmacrooptlist))))
        !           149:                   (defmcrooption 
        !           150:                        (cdr pat) 
        !           151:                        (cons 'd form) 
        !           152:                        `( (,(concatl `(ca ,@form)) . ,tmp)
        !           153:                           ,@(cond (tmp2 `((nil . ,tmp2))))
        !           154:                          . ,sofar)))))
        !           155:      nil nil)))
        !           156: 
        !           157: 
        !           158: ;--- lambdacvt :: new lambda converter.
        !           159: ;
        !           160: ; - input is  a lambda body beginning with the argument list.
        !           161: ;
        !           162: ; vrbls   :: list of (name n) where n is the arg number for name
        !           163: ; optlist :: list of (name n defval pred) where optional variable name is
        !           164: ;           (arg n) [if it exists], initval is the value if it doesn't
        !           165: ;           exist,  pred is set to non nil if the arg exists
        !           166: ; auxlist :: list of (name initial-value) for auxillary variables. (&aux)
        !           167: ; restform :: (name n) where args n to #args should be consed and assigned
        !           168: ;              to name.
        !           169: ;
        !           170: ;; strategy:
        !           171: ;  Until the compiler can compiler lexprs better, we try to avoid creating
        !           172: ; a lexpr.  A lexpr is only required if &optional or &rest forms
        !           173: ; appear.
        !           174: ;   Formal parameters which come after &aux are bound and evaluated in a let*
        !           175: ; surrounding the body.  The parameter after a &rest is put in the let*
        !           176: ; too, with an init form which is a complex do loop.  The parameters
        !           177: ; after &optional are put in the lambda expression just below the lexpr.
        !           178: ;
        !           179: (defun lambdacvt (exp)
        !           180:    (prog (vrbls optlist auxlist restform vbl fl-type optcode mainvar
        !           181:          minargs maxargs)
        !           182:       (do ((reallist (car exp) (cdr reallist))
        !           183:           (count 1 (1+ count)))
        !           184:          ((null reallist))
        !           185:          (setq vbl (car reallist))
        !           186:          (cond ((memq vbl '(&rest &body))
        !           187:                 (setq fl-type '&rest count (1- count)))
        !           188:                ((eq '&aux vbl)
        !           189:                 (setq fl-type '&aux count (1- count)))
        !           190:                ((eq '&optional vbl)
        !           191:                 (setq fl-type '&optional count (1- count)))
        !           192:                ((null fl-type)          ; just a variable
        !           193:                 (setq vrbls (cons (list vbl count) vrbls)))
        !           194:                ((eq fl-type '&rest)
        !           195:                 (cond (restform (error "Too many &rest parameters " vbl)))
        !           196:                 (setq restform (list vbl count)))
        !           197:                ((eq fl-type '&aux)
        !           198:                 (cond ((atom vbl)
        !           199:                        (setq auxlist (cons (list vbl nil) auxlist)))
        !           200:                       (t (setq auxlist (cons (list (car vbl) (cadr vbl))
        !           201:                                              auxlist)))))
        !           202:                ((eq fl-type '&optional)
        !           203:                 (cond ((atom vbl)
        !           204:                        (setq optlist
        !           205:                              (cons (list vbl count) optlist)))
        !           206:                       (t (setq optlist
        !           207:                                (cons (cons (car vbl)
        !           208:                                            (cons count
        !           209:                                                  (cdr vbl)))
        !           210:                                      optlist)))))))
        !           211: 
        !           212:       ;; arguments are collected in reverse order, but set them straight
        !           213:       (setq vrbls (nreverse vrbls)
        !           214:            optlist (nreverse optlist)
        !           215:            auxlist (nreverse auxlist)
        !           216:            minargs (length vrbls)
        !           217:            maxargs (cond (restform nil)
        !           218:                          (t (+ (length optlist) minargs))))
        !           219: 
        !           220:       ;; we must covert to a lexpr if there are &optional or &rest forms
        !           221:       (cond ((or optlist restform) (setq mainvar (gensym))))
        !           222:       
        !           223:       ; generate optionals code
        !           224:       (cond (optlist
        !           225:               (setq optcode
        !           226:                     (mapcar '(lambda (x)
        !           227:                                 `(cond ((> ,(cadr x) ,mainvar)
        !           228:                                         (setq ,(car x) ,(caddr x)))
        !           229:                                        (t (setq ,(car x)
        !           230:                                                  (arg ,(cadr x)))
        !           231:                                           ,(cond ((cdddr x)
        !           232:                                                   `(setq ,(cadddr x) t))))))
        !           233:                             optlist))))
        !           234: 
        !           235:       ;; do the rest forms
        !           236:       (cond (restform
        !           237:               (let ((dumind (gensym))
        !           238:                     (dumcol (gensym)))
        !           239:                  (setq restform
        !           240:                        `((,(car restform)
        !           241:                            (do ((,dumind ,mainvar (1- ,dumind))
        !           242:                                 (,dumcol nil (cons (arg ,dumind) ,dumcol)))
        !           243:                                ((< ,dumind ,(cadr restform)) ,dumcol))))))))
        !           244:       
        !           245:       ;; calculate body
        !           246:       (let (body)
        !           247:         (setq body (cond ((or auxlist restform)
        !           248:                             `((let* ,(append restform auxlist)
        !           249:                                  ,@(cdr exp))))
        !           250:                          (t (cdr exp))))
        !           251:         (cond ((null mainvar)          ; no &optional or &rest
        !           252:                (return `(lambda ,(mapcar 'car vrbls)
        !           253:                            (declare (*args ,minargs ,maxargs))
        !           254:                            ,@body)))
        !           255:               (t (return
        !           256:                     `(lexpr (,mainvar)
        !           257:                         (declare (*args ,minargs ,maxargs))
        !           258:                         ((lambda
        !           259:                             ,(nconc
        !           260:                                 (mapcar 'car vrbls)
        !           261:                                 (mapcan '(lambda (x)   ; may be two vrbls
        !           262:                                             (cons (car x)
        !           263:                                                   (cond ((cdddr x) ;pred?
        !           264:                                                          (ncons
        !           265:                                                             (cadddr x))))))
        !           266:                                         optlist))
        !           267:                             ,@optcode ,@body)
        !           268:                          ,@(nconc (mapcar '(lambda (x) `(arg ,(cadr x)))
        !           269:                                           vrbls)
        !           270:                                   (mapcan '(lambda (x)
        !           271:                                               (cond ((cdddr x)
        !           272:                                                      (list nil nil))
        !           273:                                                     (t (list nil))))
        !           274:                                           optlist))))))))))
        !           275: 
        !           276: ;--- defcmacro :: like defmacro but result ends up under cmacro ind
        !           277: ;
        !           278: (def defcmacro
        !           279:    (macro (args)
        !           280:        (let ((name (concat (cadr args) "::cmacro:" (gensym))))
        !           281:           `(eval-when (compile load eval)
        !           282:                    (defmacro ,name ,@(cddr args))
        !           283:                    (putprop ',(cadr args) (getd ',name) 'cmacro)
        !           284:                    (remob ',name)))))
        !           285: 
        !           286: ;;; --- setf macro
        !           287: ;
        !           288: ;(setf (cadr x) 3) --> (rplaca (cdr x) 3)
        !           289: 
        !           290: (defmacro setf (expr val &rest rest)
        !           291:          (cond ((atom expr)
        !           292:                 (or (symbolp expr)
        !           293:                     (error '|-- setf can't handle this.| expr))
        !           294:                 `(setq ,expr ,val))
        !           295:                (t
        !           296:                 (do ((y)) (())
        !           297:                     (or (symbolp (car expr))
        !           298:                         (error '|-- setf can't handle this.| expr))
        !           299:                     (and (setq y (get (car expr) 'setf-expand))
        !           300:                          (return (apply y `(,expr ,val ,@rest))))
        !           301:                     (or (setf-check-cad+r (car expr))
        !           302:                         (and
        !           303:                            (or (setq y (get (car expr) 'cmacro))
        !           304:                                (setq y (getd (car expr))))
        !           305:                            (or (and (dtpr y)
        !           306:                                     (eq (car y) 'macro))
        !           307:                                (and (bcdp y)
        !           308:                                     (eq (getdisc y) 'macro)))
        !           309:                            (setq expr (apply y expr)))
        !           310:                         (error '|-- setf can't handle this.| expr))))))
        !           311: 
        !           312: (defun setf-check-cad+r (name)
        !           313:    (if (eq (getcharn name 1) #/c)
        !           314:       then (let ((letters (nreverse (cdr (exploden name)))))
        !           315:              (if (eq (car letters) #/r)
        !           316:                 then (do ((xx (cdr letters) (cdr xx)))
        !           317:                          ((null xx)
        !           318:                           ;; form is c{ad}+r, setf form is
        !           319:                           ;; (rplac<first a or d> (c<rest of a's + d's>r x))
        !           320:                           (setq letters (nreverse letters))
        !           321:                           (eval
        !           322:                              `(defsetf ,name (e v)
        !           323:                                  (list
        !           324:                                     ',(concat "rplac" (ascii (car letters)))
        !           325:                                      (list
        !           326:                                         ',(implode `(#/c ,@(cdr letters)))
        !           327:                                         (cadr e))
        !           328:                                      v)))
        !           329:                           t)
        !           330:                          (if (not (memq (car xx) '(#/a #/d)))
        !           331:                              then (return nil)))))))
        !           332:                                           
        !           333: (defmacro defsetf (name vars &rest body)
        !           334:          `(eval-when 
        !           335:            (compile load eval)
        !           336:            (defun (,name setf-expand) ,vars . ,body)))
        !           337: 
        !           338: ;--- other setf's for car's and cdr's are generated automatically
        !           339: ;
        !           340: (defsetf car (e v) `(rplaca ,(cadr e) ,v))
        !           341: (defsetf caar (e v) `(rplaca (car ,(cadr e)) ,v))
        !           342: (defsetf cadr (e v) `(rplaca (cdr ,(cadr e)) ,v))
        !           343: (defsetf cdr (e v) `(rplacd ,(cadr e) ,v))
        !           344: (defsetf cdar (e v) `(rplacd (car ,(cadr e)) ,v))
        !           345: (defsetf cddr (e v) `(rplacd (cdr ,(cadr e)) ,v))
        !           346: (defsetf cxr (e v) `(rplacx ,(cadr e) ,(caddr e) ,v))
        !           347: 
        !           348: (defsetf vref (e v) `(vset ,(cadr e) ,(caddr e) ,v))
        !           349: (defsetf vrefi-byte (e v) `(vseti-byte ,(cadr e) ,(caddr e) ,v))
        !           350: (defsetf vrefi-word (e v) `(vseti-word ,(cadr e) ,(caddr e) ,v))
        !           351: (defsetf vrefi-long (e v) `(vseti-long ,(cadr e) ,(caddr e) ,v))
        !           352: 
        !           353: (defsetf nth (e v) `(rplaca (nthcdr ,(cadr e) ,(caddr e)) ,v))
        !           354: (defsetf nthelem (e v) `(rplaca (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v))
        !           355: (defsetf nthcdr (e v) `(rplacd (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v))
        !           356: 
        !           357: (defsetf arraycall (e v) `(store ,e ,v))
        !           358: (defsetf get (e v) `(putprop ,(cadr e) ,v ,(caddr e)))
        !           359: 
        !           360: (defsetf plist (e v) `(setplist ,(cadr e) ,v))
        !           361: 
        !           362: (defsetf symeval (e v) `(set ,(cadr e) ,v))
        !           363: 
        !           364: (defsetf arg (e v) `(setarg ,(cadr e) ,v))
        !           365: 
        !           366: (defsetf args (e v) `(args ,(cadr e) ,v))
        !           367: 
        !           368: 
        !           369: (defmacro push (object list) `(setf ,list (cons ,object ,list)))
        !           370: 
        !           371: ; this relies on the fact that setf returns the value stored.
        !           372: (defmacro pop (list &optional (into nil into-p))
        !           373:   (cond (into-p `(prog1 (setf ,into (car ,list))
        !           374:                         (setf ,list (cdr ,list))))
        !           375:         (t `(prog1 (car ,list)
        !           376:                    (setf ,list (cdr ,list))))))
        !           377: 
        !           378: ; let for franz (with destructuring)
        !           379: ;--- let
        !           380: ;      - binds - binding forms
        !           381: ;      - . body - forms to execute
        !           382: ; the binding forms may have these forms
        !           383: ;   a  local variable a, initially nil
        !           384: ;  (a x)  local variable a, x is evaled and a gets its value initially
        !           385: ;  ((a . (b . c)) x)   three local variables, a,b and c which are given
        !           386: ;                      values corresponding to the location in the value
        !           387: ;                      of x.  Any structure is allowed here. 
        !           388: ;
        !           389: (defmacro let (binds &rest body &aux vrbls vals destrs newgen)
        !           390:   (mapc '(lambda (form)
        !           391:                (cond ((atom form)
        !           392:                       (setq vrbls (cons form vrbls)
        !           393:                             vals  (cons nil vals)))
        !           394:                      ((atom (car form))
        !           395:                       (setq vrbls (cons (car form) vrbls)
        !           396:                             vals  (cons (cadr form) vals)))
        !           397:                      (t (setq newgen (gensym)
        !           398:                               destrs `((,newgen ,@(de-compose (car form) '(r)))
        !           399:                                        ,@destrs)
        !           400:                               vrbls  (cons newgen vrbls)
        !           401:                               vals   (cons (cadr form) vals)))))
        !           402:        binds)
        !           403: 
        !           404:   (mapc '(lambda (frm)
        !           405:                (do ((ll (cdr frm) (cdr ll)))
        !           406:                    ((null ll))
        !           407:                    (setq vrbls (cons (cdar ll) vrbls)
        !           408:                          vals  (cons nil vals))))
        !           409:        destrs)
        !           410: 
        !           411:   (setq vals (nreverse vals)
        !           412:        vrbls (nreverse vrbls)
        !           413:        destrs (nreverse destrs))
        !           414:   `((lambda ,vrbls
        !           415:            ,@(mapcan '(lambda (frm)
        !           416:                               (mapcar '(lambda (vrb)
        !           417:                                                `(setq ,(cdr vrb) (,(car vrb)
        !           418:                                                                  ,(car frm))))
        !           419:                                       (cdr frm)))
        !           420:                      destrs)
        !           421:            ,@body)
        !           422:     ,@vals))
        !           423: 
        !           424: ;--- de-compose
        !           425: ;              form - pattern to de-compose
        !           426: ;              sofar - the sequence of cxxr's needed to get to this part
        !           427: ;                      of the pattern
        !           428: ;  de-compose returns a list of this form
        !           429: ;
        !           430: ;      ((cxxr . a) (cyyr . b) ... )
        !           431: ; which tells how to get to the value for a and b ..etc..
        !           432: ;
        !           433: (def de-compose 
        !           434:   (lambda (form sofar)
        !           435:          (cond ((null form ) nil)
        !           436:                ((atom form) (ncons (cons (apply 'concat (cons 'c sofar))
        !           437:                                          form)))
        !           438:                (t (nconc (de-compose (car form) (cons 'a sofar))
        !           439:                          (de-compose (cdr form) (cons 'd sofar)))))))
        !           440: 
        !           441: ;--- caseq
        !           442: ; use is 
        !           443: ;    (caseq expr
        !           444: ;          (match1 do1)
        !           445: ;          (match2 do2)
        !           446: ;          (t  doifallelsefails))
        !           447: ; the matchi can be atoms in which case an 'eq' test is done, or they
        !           448: ; can be lists in which case a 'memq' test is done.
        !           449: ;
        !           450: 
        !           451: (defmacro caseq (switch &body clauses &aux var code)
        !           452:    (setq var (cond ((symbolp switch) switch) ((gensym 'Z))))
        !           453:    (setq code
        !           454:         `(cond . ,(mapcar '(lambda (clause)
        !           455:                               (cons
        !           456:                                  (let ((test (car clause)))
        !           457:                                     (cond ((eq test t) t)
        !           458:                                           ((dtpr test)
        !           459:                                            `(memq ,var ',test))
        !           460:                                           (t `(eq ,var ',test))))
        !           461:                                  (cdr clause)))
        !           462:                           clauses)))
        !           463:    (cond ((symbolp switch) code)
        !           464:         (`((lambda (,var) ,code) ,switch))))
        !           465: 
        !           466: ;--- selectq :: just like caseq
        !           467: ; except 'otherwise' is recogized as equivalent to 't' as a key
        !           468: ;
        !           469: (defmacro selectq (key . forms)
        !           470:          (setq forms
        !           471:                (mapcar '(lambda (form) (if (eq (car form) 'otherwise)
        !           472:                                             (cons t (cdr form)) form))
        !           473:                        forms))
        !           474:          `(caseq ,key . ,forms))
        !           475: 
        !           476: ;--- let*
        !           477: ;      - binds  - binding forms (like let)
        !           478: ;      - body   - forms to eval (like let)
        !           479: ; this is the same as let, except forms are done in a left to right manner
        !           480: ; in fact, all we do is generate nested lets
        !           481: ;
        !           482: (defmacro let* (binds &rest body)
        !           483:   (do ((ll (reverse binds) (cdr ll)))
        !           484:       ((null ll) (car body))
        !           485:       (setq body `((let (,(car ll)) ,@body)))))
        !           486: 
        !           487: 
        !           488:                   
        !           489: ;--- listify : n  - integer
        !           490: ;      returns a list of the first n args to the enclosing lexpr if
        !           491: ; n is positive, else returns the last -n args to the lexpr if n is
        !           492: ; negative.
        !           493: ; returns nil if n is 0
        !           494: ;
        !           495: (def listify 
        !           496:   (macro (lis)
        !           497:         `(let ((n ,(cadr lis)))
        !           498:               (cond ((eq n 0) nil)
        !           499:                     ((minusp n)
        !           500:                      (do ((i (arg nil)  (1- i))
        !           501:                           (result nil (cons (arg i) result)))
        !           502:                          ((<& i (+ (arg nil) n  1)) result) ))
        !           503:                     (t (do ((i n  (1- i))
        !           504:                             (result nil (cons (arg i) result)))
        !           505:                            ((<& i 1) result) ))))))
        !           506: 
        !           507: ;--- include-if
        !           508: ; form: (include-if <predicate> <filename>)
        !           509: ;  will return (include <filename>) if <predicate> is non-nil
        !           510: ;  This is useful at the beginning of a file to conditionally
        !           511: ;  include a file based on whether it has already been included.
        !           512: ;
        !           513: (defmacro include-if (pred filename)
        !           514:    (cond ((eval pred) `(include ,filename))))
        !           515: 
        !           516: ;--- includef-if
        !           517: ; form: (includef-if <predicate> '<filename>)
        !           518: ;  like the above except it includef's the file.
        !           519: ;
        !           520: (defmacro includef-if (pred filenameexpr)
        !           521:    (cond ((eval pred) `(includef ,filenameexpr))))
        !           522: 
        !           523: ;--- if :: macro for doing conditionalization
        !           524: ;
        !           525: ;  This macro is compatible with both the crufty mit-version and
        !           526: ; the keyword version at ucb.
        !           527: ;
        !           528: ;  simple summary:
        !           529: ;   non-keyword use:
        !           530: ;      (if a b) ==> (cond (a b))
        !           531: ;      (if a b c d e ...) ==> (cond (a b) (t c d e ...))
        !           532: ;   with keywords:
        !           533: ;      (if a then b) ==> (cond (a b))
        !           534: ;      (if a thenret) ==> (cond (a))
        !           535: ;      (if a then b c d e) ==> (cond (a b c d e))
        !           536: ;      (if a then b c  else d) ==> (cond (a b c) (t d))
        !           537: ;      (if a then b c  elseif d  thenret  else g)
        !           538: ;              ==> (cond (a b c) (d) (t g))
        !           539: ;
        !           540: ;   
        !           541: ;
        !           542: ;
        !           543: ; In the syntax description below,
        !           544: ;    optional parts are surrounded by [ and ],
        !           545: ;    + means one or more instances.
        !           546: ;    | means 'or'
        !           547: ;    <expr> is an lisp expression which isn't a keyword
        !           548: ;       The keywords are:  then, thenret, else, elseif.
        !           549: ;    <pred> is also a lisp expression which isn't a keyword.
        !           550: ; 
        !           551: ; <if-stmt> ::=  <simple-if-stmt>
        !           552: ;             | <keyword-if-stmt>
        !           553: ; 
        !           554: ; <simple-if-stmt> ::=  (if <pred> <expr>)
        !           555: ;                    | (if <pred> <expr> <expr>)
        !           556: ; 
        !           557: ; <keyword-if-stmt> ::= (if <pred> <then-clause> [ <else-clause> ] )
        !           558: ; 
        !           559: ; <then-clause> ::=  then <expr>+
        !           560: ;                 | thenret
        !           561: ; 
        !           562: ; <else-clause> ::=  else <expr>+
        !           563: ;                 | elseif <pred> <then-clause> [ <else-clause> ]
        !           564: ;
        !           565: 
        !           566: (declare (special if-keyword-list))
        !           567: 
        !           568: (eval-when (compile load eval)
        !           569:    (setq if-keyword-list '(then thenret elseif else)))
        !           570: 
        !           571: ;--- if
        !           572: ;
        !           573: ;  the keyword if expression is parsed using a simple four state
        !           574: ; automaton.  The expression is parsed in reverse.
        !           575: ; States:
        !           576: ;      init - have parsed a complete predicate,  then clause
        !           577: ;      col  - have collected at least one non keyword in col
        !           578: ;      then - have just seen a then, looking for a predicate
        !           579: ;      compl - have just seen a predicate after an then, looking
        !           580: ;              for elseif or if (i.e. end of forms).
        !           581: ;
        !           582: (defmacro if (&rest args)
        !           583:    (let ((len (length args)))
        !           584:       ;; first eliminate the non-keyword if macro cases
        !           585:       (cond ((<& len 2)
        !           586:             (error "if: not enough arguments " args))
        !           587:            ((and (=& len 2)
        !           588:                  (not (memq (cadr args) if-keyword-list)))
        !           589:             `(cond (,(car args) ,(cadr args))))
        !           590:            ; clause if there are not keywords (and len > 2)
        !           591:            ((do ((xx args (cdr xx)))
        !           592:                 ((null xx) t)
        !           593:                 (cond ((memq (car xx) if-keyword-list)
        !           594:                        (return nil))))
        !           595:             `(cond (,(car args) ,(cadr args))
        !           596:                    (t ,@(cddr args))))
        !           597:            
        !           598:            ;; must be an instance of a keyword if macro
        !           599:            
        !           600:            (t (do ((xx (reverse args) (cdr xx))
        !           601:                    (state 'init)
        !           602:                    (elseseen nil)
        !           603:                    (totalcol nil)
        !           604:                    (col nil))
        !           605:                   ((null xx)
        !           606:                    (cond ((eq state 'compl)
        !           607:                           `(cond ,@totalcol))
        !           608:                          (t (error "if: illegal form " args))))
        !           609:                   (cond ((eq state 'init)
        !           610:                          (cond ((memq (car xx) if-keyword-list)
        !           611:                                 (cond ((eq (car xx) 'thenret)
        !           612:                                        (setq col nil
        !           613:                                              state 'then))
        !           614:                                       (t (error "if: bad keyword "
        !           615:                                                 (car xx) args))))
        !           616:                                (t (setq state 'col
        !           617:                                         col nil)
        !           618:                                   (push (car xx) col))))
        !           619:                         ((eq state 'col)
        !           620:                          (cond ((memq (car xx) if-keyword-list)
        !           621:                                 (cond ((eq (car xx) 'else)
        !           622:                                        (cond (elseseen
        !           623:                                                 (error
        !           624:                                                    "if: multiples elses "
        !           625:                                                    args)))
        !           626:                                        (setq elseseen t)
        !           627:                                        (setq state 'init)
        !           628:                                        (push `(t ,@col) totalcol))
        !           629:                                       ((eq (car xx) 'then)
        !           630:                                        (setq state 'then))
        !           631:                                       (t (error "if: bad keyword "
        !           632:                                                 (car xx) args))))
        !           633:                                (t (push (car xx) col))))
        !           634:                         ((eq state 'then)
        !           635:                          (cond ((memq (car xx) if-keyword-list)
        !           636:                                 (error "if: keyword at the wrong place "
        !           637:                                        (car xx) args))
        !           638:                                (t (setq state 'compl)
        !           639:                                   (push `(,(car xx) ,@col) totalcol))))
        !           640:                         ((eq state 'compl)
        !           641:                          (cond ((not (eq (car xx) 'elseif))
        !           642:                                 (error "if: missing elseif clause " args)))
        !           643:                          (setq state 'init))))))))
        !           644: 
        !           645: ;--- If :: the same as 'if' but defined for those programs that still
        !           646: ;      use it.
        !           647: ;
        !           648: (putd 'If (getd 'if))
        !           649: 
        !           650: ;--- defvar :: a macro for declaring a variable special
        !           651: ;  a variable declared special with defvar will be special when the
        !           652: ; file containing the variable is compiled and also when the file
        !           653: ; containing the defvar is loaded in.  Furthermore, you can specify
        !           654: ; an default value for the variable. It will be set to that value
        !           655: ; iff it is unbound
        !           656: ;
        !           657: (defmacro defvar (variable &optional (initial-value nil iv-p) documentation)
        !           658:   (if iv-p
        !           659:      then `(progn 'compile
        !           660:                   (eval-when (eval compile load)
        !           661:                          (eval '(liszt-declare (special ,variable))))
        !           662:                   (or (boundp ',variable) (setq ,variable ,initial-value)))
        !           663:      else `(eval-when (eval compile load)
        !           664:                  (eval '(liszt-declare (special ,variable))))))
        !           665: 
        !           666: 
        !           667: 
        !           668: 
        !           669: (defmacro list* (&rest forms)
        !           670:          (cond ((null forms) nil)
        !           671:                ((null (cdr forms)) (car forms))
        !           672:                (t (construct-list* forms))))
        !           673: 
        !           674: (eval-when (load compile eval)
        !           675:    (defun construct-list* (forms)
        !           676:          (setq forms (reverse forms))
        !           677:          (do ((forms (cddr forms) (cdr forms))
        !           678:               (return-form `(cons ,(cadr forms) ,(car forms))
        !           679:                             `(cons ,(car forms) ,return-form)))
        !           680:              ((null forms) return-form))))
        !           681: 
        !           682: ;; (<= a b) --> (not (> a b))
        !           683: ;; (<= a b c) --> (not (or (> a b) (> b c)))
        !           684: ;; funny arglist to check for correct number of arguments.
        !           685: 
        !           686: 
        !           687: (defmacro <= (arg1 arg2 &rest rest &aux result)
        !           688:   (setq rest (list* arg1 arg2 rest))
        !           689:   (do l rest (cdr l) (null (cdr l))
        !           690:       (push `(> ,(car l) ,(cadr l)) result))
        !           691:   (cond ((null (cdr result)) `(not ,(car result)))
        !           692:        (t `(not (or . ,(nreverse result))))))
        !           693: 
        !           694: (defmacro <=& (x y)
        !           695:    `(not (>& ,x ,y)))
        !           696: 
        !           697: ;; (>= a b) --> (not (< a b))
        !           698: ;; (>= a b c) --> (not (or (< a b) (< b c)))
        !           699: ;; funny arglist to check for correct number of arguments.
        !           700: 
        !           701: (defmacro >= (arg1 arg2 &rest rest &aux result)
        !           702:   (setq rest (list* arg1 arg2 rest))
        !           703:   (do l rest (cdr l) (null (cdr l))
        !           704:       (push `(< ,(car l) ,(cadr l)) result))
        !           705:   (cond ((null (cdr result)) `(not ,(car result)))
        !           706:        (t `(not (or . ,(nreverse result))))))
        !           707: 
        !           708: 
        !           709: (defmacro >=& (x y)
        !           710:    `(not (<& ,x ,y)))

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