Return to cmumacs.l CVS log

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

Annotation of 43BSD/ucb/lisp/lisplib/cmumacs.l, revision 1.1

1.1     ! root        1: ;; file of common cmu functions which should be macros 
        !             2: ;; I hope that by just loading in the file an environment will be
        !             3: ;; created which will permit the cmu files to be compiled.
        !             4: 
        !             5: (setq rcs-cmumacs-
        !             6:    "$Header: /usr/lib/lisp/cmumacs.l,v 1.1 83/01/29 18:34:31 jkf Exp $")
        !             7: 
        !             8: (declare (macros t))
        !             9: 
        !            10: (eval-when (compile eval load)
        !            11:    (or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))
        !            12: 
        !            13: ;-- contents
        !            14: ;      dv      mark!changed    ***     list* [construct-list* lambda]
        !            15: ;      neq     push    pop     mukname (equivlance)
        !            16: ;      prin1 (equiv to print)  selectq lineread
        !            17: ;
        !            18: 
        !            19: ;--- dv :: set variable to value and remember it was changed
        !            20: ; (dv name value)   name is setq'ed to value (no evaluation) and
        !            21: ;               the fact that it was done is remembered
        !            22: ;
        !            23: (defmacro dv (name value)
        !            24:   `(progn 'compile
        !            25:          (setq ,name ',value)
        !            26:          (mark!changed ',name)))
        !            27: 
        !            28: (defmacro mark!changed (name)
        !            29:   `(let ((atomname ,name))
        !            30:         (and (boundp '%changes) (setq %changes (cons atomname %changes)))
        !            31:        atomname))
        !            32: 
        !            33: ;--- *** :: comment macro
        !            34: ;
        !            35: (defmacro *** (&rest x) nil)
        !            36: 
        !            37: ;; this must be rewritten as a macro           ****
        !            38: ;(def quote! (nlambda (a) (quote!-expr a)))
        !            39: 
        !            40: ; this will be thrown away if the code below it works
        !            41: (def quote!-expr
        !            42:      (lambda 
        !            43:       (x)
        !            44:       (cond ((atom x) x)
        !            45:             ((eq (car x) '!)
        !            46:              (cons (eval (cadr x)) (quote!-expr (cddr x))))
        !            47:             ((eq (car x) '!!)
        !            48:              (cond ((cddr x)
        !            49:                     (append (eval (cadr x)) (quote!-expr (cddr x))))
        !            50:                    (t (eval (cadr x)))))
        !            51:             (t
        !            52:              (prog (u v)
        !            53:                    (setq u (quote!-expr (car x)))
        !            54:                    (setq v (quote!-expr (cdr x)))
        !            55:                    (cond ((and (eq u (car x)) (eq v (cdr x))) (return x)))
        !            56:                    (return (cons u v)))))))
        !            57: ;; this is probably what the above forms do. (jkf)
        !            58: (defmacro quote! (&rest a) (quote!-expr-mac a))
        !            59: (eval-when (compile eval load)
        !            60:    
        !            61: (defun quote!-expr-mac (form)
        !            62:    (cond ((null form) nil)
        !            63:         ((atom form) `',form)
        !            64:         ((eq (car form) '!)
        !            65:          `(cons ,(cadr form) ,(quote!-expr-mac (cddr form))))
        !            66:         ((eq (car form) '!!)
        !            67:          (cond ((cddr form) `(append ,(cadr form)
        !            68:                                       ,(quote!-expr-mac (cddr form))))
        !            69:                (t (cadr form))))
        !            70:         (t `(cons ,(quote!-expr-mac (car form))
        !            71:                    ,(quote!-expr-mac (cdr form))))))
        !            72: 
        !            73: ); end eval-when
        !            74:                 
        !            75:         
        !            76: ;--- the following are macroizations from cmu3.l
        !            77: 
        !            78: ;(jkf)- ucb list* macro.
        !            79: ;
        !            80: (defmacro list* (&rest forms)
        !            81:          (cond ((null forms) nil)
        !            82:                ((null (cdr forms)) (car forms))
        !            83:                (t (construct-list* forms))))
        !            84: 
        !            85: (defun construct-list* (forms)
        !            86:        (setq forms (reverse forms))
        !            87:        (do ((forms (cddr forms) (cdr forms))
        !            88:            (return-form `(cons ,(cadr forms) ,(car forms))
        !            89:                         `(cons ,(car forms) ,return-form)))
        !            90:           ((null forms) return-form))) 
        !            91: 
        !            92: (defmacro neq (a b) `(not (eq ,a ,b)))
        !            93: 
        !            94: 
        !            95: (defmacro push (value stack) `(setq ,stack (cons ,value ,stack)))
        !            96: 
        !            97: 
        !            98: 
        !            99: 
        !           100: 
        !           101: ;(jkf) this is actually maknum is the maclisp terminology
        !           102: (putd 'munknam (getd 'maknum))
        !           103: 
        !           104: ; added for CMULisp compatibilty (used by editor etc)
        !           105: (putd 'prin1 (getd 'print))
        !           106: 
        !           107: ;--- selectq :: case statement type construct
        !           108: ;
        !           109: ;   (selectq <form>
        !           110: ;           (<tag1> <expr1> ...)
        !           111: ;           (<tag2> <expr2> ...)
        !           112: ;               ...
        !           113: ;           (<tagn> <exprn> ...)
        !           114: ;            (<exprfinal> ...))
        !           115: ; <form> is evaluated and then compared with the tagi, if it matches
        !           116: ; the expri are evaluated.  If it doesn't match, then <exprfinal> are
        !           117: ; evaluated.
        !           118: ;
        !           119: (def selectq
        !           120:    (macro (form)
        !           121:          ((lambda (x)
        !           122:                   `((lambda (,x)
        !           123:                             (cond
        !           124:                                  ,@(maplist
        !           125:                                         '(lambda (ff)
        !           126:                                                  (cond ((null (cdr ff))
        !           127:                                                         `(t  ,(car ff)))
        !           128:                                                        ((atom (caar ff))
        !           129:                                                         `((eq ,x ',(caar ff))
        !           130:                                                           . ,(cdar ff)))
        !           131:                                                        (t
        !           132:                                                             `((memq ,x ',(caar ff))
        !           133:                                                               . ,(cdar ff)))))
        !           134:                                          (cddr form))))
        !           135:                     ,(cadr form)))
        !           136:          (gensym 'Z))))
        !           137: 
        !           138: (defmacro lineread (&optional (x nil)) 
        !           139:   `(%lineread ,x))
        !           140: 
        !           141: 
        !           142: 
        !           143: (defmacro de (name &rest body)
        !           144:    (cond ((status feature complr) `(def ,name (lambda ,@body)))
        !           145:         (t `(progn (putd ,name '(lambda ,@body))
        !           146:                    (mark!changed ',name)))))
        !           147: (defmacro dn (name &rest body)
        !           148:    (cond ((status feature complr) `(def ,name (nlambda ,@body)))
        !           149:         (t `(progn (putd ,name '(nlambda ,@body))
        !           150:                    (mark!changed ',name)))))
        !           151: (defmacro dm (name &rest body)
        !           152:    (cond ((status feature complr) `(def ,name (macro ,@body)))
        !           153:         (t `(progn (putd ,name '(macro ,@body))
        !           154:                    (mark!changed ',name)))))
        !           155: 
        !           156: (eval-when (compile eval load)
        !           157:    (or (boundp 'OLD-fcn-def) (setq OLD-fcn-def (getd 'def))))
        !           158: 
        !           159: (defmacro def (&rest form)
        !           160:     (cond ((status feature complr)
        !           161:           `(progn 'compile
        !           162:                    (eval-when (compile) (putd 'def OLD-fcn-def))
        !           163:                    (def ,@form)
        !           164:                    (eval-when (compile) (putd 'def CMU-fcn-def))))
        !           165:          (t `(progn (putd ',(car form) ',(cadr form))
        !           166:                    (mark!changed ',(car form))))))
        !           167: 
        !           168: (eval-when (compile eval load)
        !           169:    (or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))
        !           170: 
        !           171: ;--iteration macros
        !           172: 
        !           173: (def Cdo (macro (l) (expand-do l)))
        !           174: 
        !           175: (def exists (macro (l) (expand-ex 'some l)))
        !           176: 
        !           177: (declare (special var))
        !           178: 
        !           179: (eval-when (compile eval load)
        !           180:    
        !           181: (def expand-ex
        !           182:      (lambda 
        !           183:       (fn form)
        !           184:       (quote! !
        !           185:               fn
        !           186:               !
        !           187:               (caddr form)
        !           188:               (function
        !           189:                (lambda 
        !           190:                 !
        !           191:                 (cond ((atom (cadr form)) (ncons (cadr form)))
        !           192:                       (t (cadr form)))
        !           193:                 !
        !           194:                 (car (setq form (cdddr form)))))
        !           195:               !
        !           196:               (cond ((cdr form) (list 'function (cadr form)))))))
        !           197: ) ; end eval-when
        !           198: 
        !           199: (def expand-do
        !           200:      (lambda 
        !           201:       (l)
        !           202:       (prog (label var init incr limit part)
        !           203:             (cond
        !           204:              ((setq part (memq 'for l))
        !           205:               (setq var (cadr part))
        !           206:               (setq l (append (ldiff l part) (cddr part)))))
        !           207:             (cond
        !           208:              ((setq part (exists w l (memq w '(gets = _ :=))))
        !           209:               (setq init (cadr part))
        !           210:               (setq l (append (ldiff l part) (cddr part)))))
        !           211:             (cond
        !           212:              ((setq part (exists w l (memq w '(step by))))
        !           213:               (setq incr (cadr part))
        !           214:               (setq l (append (ldiff l part) (cddr part)))))
        !           215:             (cond
        !           216:              ((setq part (memq 'to l))
        !           217:               (setq limit (cadr part))
        !           218:               (setq l (append (ldiff l part) (cddr part)))))
        !           219:             (return
        !           220:              (quote! prog
        !           221:                      !
        !           222:                      (cond (var (ncons var)))
        !           223:                      !!
        !           224:                      (cond
        !           225:                       (var
        !           226:                        (ncons
        !           227:                         (list 'setq var (cond (init) (t 1))))))
        !           228:                      !
        !           229:                      (setq label (gensym))
        !           230:                      !!
        !           231:                      (mapcan (function
        !           232:                               (lambda 
        !           233:                                (exp)
        !           234:                                (cond ((eq part 'while)
        !           235:                                       (setq part nil)
        !           236:                                       (quote!
        !           237:                                        (cond
        !           238:                                         ((not ! exp) (return nil)))))
        !           239:                                      ((eq part 'until)
        !           240:                                       (setq part nil)
        !           241:                                       (quote!
        !           242:                                        (cond (! exp (return nil)))))
        !           243:                                      ((memq (setq part exp)
        !           244:                                             '(while until do Cdo))
        !           245:                                       nil)
        !           246:                                      (t (ncons exp)))))
        !           247:                              l)
        !           248:                      !!
        !           249:                      (cond
        !           250:                       (var
        !           251:                        (quote!
        !           252:                         (setq ! var (+ ! var ! (cond (incr) (t 1)))))))
        !           253:                      !!
        !           254:                      (cond
        !           255:                       ((and var limit)
        !           256:                        (quote! (cond ((> ! var ! limit) (return nil))))))
        !           257:                      (go ! label))))))
        !           258: 
        !           259: 
        !           260: (def expand-fe
        !           261:      (lambda 
        !           262:       (form)
        !           263:       (prog (vars body)
        !           264:             (return
        !           265:              (cons (cond ((memq (cadr form)
        !           266:                                 (quote
        !           267:                                  (map mapc
        !           268:                                       mapcan
        !           269:                                       mapcar
        !           270:                                       mapcon
        !           271:                                       mapconc
        !           272:                                       maplist)))
        !           273:                           (setq form (cdr form))
        !           274:                           (car form))
        !           275:                          (t 'mapc))
        !           276:                    (progn (setq vars (cadr form))
        !           277:                           (cond ((atom vars) (setq vars (list vars))))
        !           278:                           (cons (cons 'function
        !           279:                                       (ncons
        !           280:                                        (cons 'lambda
        !           281:                                              (cons vars
        !           282:                                                    (setq body
        !           283:                                                          (Cnth (cdddr
        !           284:                                                                 form)
        !           285:                                                                (length
        !           286:                                                                 vars)))))))
        !           287:                                 (ldiff (cddr form) body))))))))
        !           288: (def expand-set-of
        !           289:      (lambda 
        !           290:       (form)
        !           291:       (prog (vars body)
        !           292:             (setq vars (cadr form))
        !           293:             (cond ((atom vars) (setq vars (list vars))))
        !           294:             (setq form (cddr form))
        !           295:             (return
        !           296:              (quote! mapcan
        !           297:                      (function
        !           298:                       (lambda 
        !           299:                        !
        !           300:                        vars
        !           301:                        (cond
        !           302:                         (! (car
        !           303:                             (setq body (Cnth (cdr form) (length vars))))
        !           304:                            (list ! (car vars))))))
        !           305:                      !!
        !           306:                      (ldiff form body))))))
        !           307: 
        !           308: (dv filelst nil)
        !           309: 
        !           310: (def for (macro (l) (expand-do l)))
        !           311: 
        !           312: (def for-each (macro (l) (expand-fe l)))
        !           313: 
        !           314: (def forall (macro (l) (expand-ex 'every l)))
        !           315: 
        !           316: (def set-of (macro (l) (expand-set-of l)))
        !           317: 
        !           318: (def ty (macro (f) (append '(exec cat) (cdr f))))
        !           319: 
        !           320: (def until (macro (l) (expand-do l)))
        !           321: 
        !           322: (def while (macro (l) (expand-do l)))
        !           323: 
        !           324: (putprop 'cmumacs t 'version)

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