Return to machacks.l CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib

Annotation of 3BSD/cmd/lisp/lib/machacks.l, revision 1.1

1.1     ! root        1: ; this file will be loaded whenever the -m switch is set for compilation.
        !             2: ; NOTE this file is loaded after the maclisp syntax has been set up!!
        !             3: (sstatus dumpcore t)
        !             4: (sstatus feature unix)
        !             5: (setsyntax '/ 2)
        !             6: 
        !             7: (def macsyma-env               ; put at the beginning of each macsyma file
        !             8:   (macro (l) `(include |//usr//staff//jkf//mac//libmax//prelud.l|)))
        !             9: 
        !            10: (def franzify
        !            11:   (macro (l) `(eval-when (compile eval)
        !            12:                         (sstatus feature franz)
        !            13:                         (sstatus feature unix)
        !            14:                         (sstatus nofeature maclisp)
        !            15:                         (sstatus nofeature its))))
        !            16: (def error
        !            17:   (lexpr (a)
        !            18:         (terpr)
        !            19:         (patom '|Error: |)
        !            20:         (do ((ll a (sub1 ll)))
        !            21:             ((zerop ll)(terpr))
        !            22:             (patom (arg ll)))))
        !            23: 
        !            24: (def fasload 
        !            25:   (nlambda (argl)
        !            26:           (fasl (concat '|//usr//staff//jkf//mac//| 
        !            27:                         (cadddr argl)          ; fourth arg
        !            28:                         '|//| 
        !            29:                         (car argl)             ; first arg
        !            30:                         '|.|
        !            31:                         (cadr argl)))))        ; second arg
        !            32: 
        !            33: (def coutput
        !            34:   (lambda (msg)
        !            35:          (print msg)   ; should go to unfasl port
        !            36:          (terpr)))
        !            37: 
        !            38: (opval 'pagelimit 5000.)
        !            39: 
        !            40: (defmacro let (binding-forms &rest body)
        !            41:          `((lambda ,(mapcar '(lambda (x) (cond ((atom x) x) (t (car x))))
        !            42:                             binding-forms)
        !            43:                    ,@body)
        !            44:            ,@(mapcar '(lambda (x) (cond ((atom x) nil)
        !            45:                                         ((null (cdr x)) nil)
        !            46:                                         (t (cadr x))))
        !            47:                      binding-forms)))
        !            48: 
        !            49: (defmacro let* (binding-forms &rest body)
        !            50:     (construct-let* (reverse binding-forms) body))
        !            51: 
        !            52: (defun construct-let* (binding-forms body)
        !            53:   (cond ((null binding-forms)
        !            54:         (cond ((= (length body) 1) (car body))
        !            55:               (t `(progn . ,body))))
        !            56:        (t (construct-let*
        !            57:            (cdr binding-forms)
        !            58:            (cond
        !            59:             ;;(let* (a b) x) --> ((lambda (a) ((lambda (b) x) nil)) nil)
        !            60:             ((atom (car binding-forms))
        !            61:              `(((lambda (,(car binding-forms)) . ,body) nil)))
        !            62:             ;;(let* (((a . b) v) x)) -->
        !            63:             ;;  ((lambda (let*val) 
        !            64:             ;;     ((lambda (a) (setq let*val (cdr let*val))
        !            65:             ;;                  ((lambda (b) x)
        !            66:             ;;                   let*val))
        !            67:             ;;      (car let*val)))
        !            68:             ;;   v)
        !            69:             ((null (atom (caar binding-forms)))
        !            70:              `(((lambda (let*val) ,(constr-let*-hack (caar binding-forms)
        !            71:                                                      body))
        !            72:                 ,(cadar binding-forms))))
        !            73:             
        !            74:             ;;(let* ((a) (b)) x) --> ((lambda (a) ((lambda (b) x) nil)) nil)
        !            75:             ((null (cdar binding-forms))
        !            76:              `(((lambda (,(caar binding-forms)) . ,body) nil)))
        !            77:             ;;(let* ((a 3) (b 4)) x) --> ((lambda (a) ((lambda (b) x) 4)) 3)
        !            78:             (t `(((lambda (,(caar binding-forms)) . ,body)
        !            79:                   ,(cadar binding-forms)))))))))
        !            80: 
        !            81: (defun constr-let*-hack (lst body)
        !            82:   (cond ((atom lst) `((lambda (,lst) ,@body) let*val))
        !            83:        ((null (cdr lst))
        !            84:           `((lambda (,(car lst)) ,@body) (car let*val)))
        !            85:        (t `((lambda (,(car lst)) (setq let*val (cdr let*val))
        !            86:                                  ,(constr-let*-hack (cdr lst)
        !            87:                                                     body))
        !            88:             (car let*val)))))
        !            89: 
        !            90: (defmacro list* (&rest forms)
        !            91:          (cond ((null forms) nil)
        !            92:                ((null (cdr forms)) (car forms))
        !            93:                (t (construct-list* forms))))
        !            94: 
        !            95: (defun construct-list* (forms)
        !            96:        (setq forms (reverse forms))
        !            97:        (do ((forms (cddr forms) (cdr forms))
        !            98:            (return-form `(cons ,(cadr forms) ,(car forms))
        !            99:                         `(cons ,(car forms) ,return-form)))
        !           100:           ((null forms) return-form)))
        !           101: 
        !           102: (defun displace (old-form new-form)
        !           103:        (cond ((atom old-form)
        !           104:              (error '|Not able to displace this form| old-form))
        !           105:             ((atom new-form)
        !           106:              (rplaca old-form 'progn)
        !           107:              (rplacd old-form (list new-form)))
        !           108:             (t (rplaca old-form (car new-form))
        !           109:                (rplacd old-form (cdr new-form)))))
        !           110: 
        !           111: (def caseq
        !           112:   (macro (form)
        !           113:           ((lambda (x)
        !           114:                    `((lambda (,x)
        !           115:                              (cond 
        !           116:                               ,@(mapcar '(lambda (ff)
        !           117:                                                  (cond ((eq (car ff) 't)
        !           118:                                                         `(t ,(cadr ff)))
        !           119:                                                        (t `((eq ,x ',(car ff))
        !           120:                                                             ,(cadr ff)))))
        !           121:                                         (cddr form))))
        !           122:                      ,(cadr form)))
        !           123:            (gensym 'Z))))
        !           124: 

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