Return to machacks.l CVS log

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

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

1.1     ! root        1: (setq rcs-machacks-
        !             2:    "$Header: machacks.l 1.5 83/07/05 00:04:09 jkf Exp $")
        !             3: 
        !             4: ;; (c) copywrite 1982, University of California, Berkeley
        !             5: ;; (c) copywrite 1982, Massachusetts Insititute of Technology
        !             6: 
        !             7: ;; This file was originally written at the University of California,
        !             8: ;; Berkeley.  Some portions were modified and additions made were made at
        !             9: ;; MIT.
        !            10: 
        !            11: ;; machacks - maclisp compatibility package.
        !            12: ;; when this file is fasl'ed into a lisp, it will change the syntax to
        !            13: ;; maclisp's syntax and will define functions know to the standard maclisp.
        !            14: ;; it is also used to bootstrap vaxima compilation.
        !            15: ;
        !            16: ; this file will be fasled whenever the -m switch is set for compilation.
        !            17: ;
        !            18: 
        !            19: (declare (macros t))
        !            20: 
        !            21: (def coutput
        !            22:   (lambda (msg)
        !            23:          (print msg)   ; should go to unfasl port
        !            24:          (terpr)))
        !            25: 
        !            26: ;--- displace 
        !            27: ; this is useful after a macro has been expanded and you want to save the
        !            28: ; interpreter the trouble of expanding the macro again.  
        !            29: ; [this is really only useful for interpretation]
        !            30: (defun displace (old-form new-form)
        !            31:        (cond ((atom old-form)
        !            32:              (error '|not able to displace this form| old-form))
        !            33:             ((atom new-form)
        !            34:              (rplaca old-form 'progn)
        !            35:              (rplacd old-form (list new-form)))
        !            36:             (t (rplaca old-form (car new-form))
        !            37:                (rplacd old-form (cdr new-form)))))
        !            38: 
        !            39: 
        !            40: 
        !            41: ;--- fboundp  :: check if a symbol has a function binding
        !            42: ;
        !            43: (defmacro fboundp (form &protect (form)) `(and (symbolp ,form) (getd ,form)))
        !            44: 
        !            45: 
        !            46: 
        !            47: 
        !            48: (defmacro list* (&rest forms)
        !            49:          (cond ((null forms) nil)
        !            50:                ((null (cdr forms)) (car forms))
        !            51:                (t (construct-list* forms))))
        !            52: 
        !            53: (eval-when (load compile eval)
        !            54:    (defun construct-list* (forms)
        !            55:          (setq forms (reverse forms))
        !            56:          (do ((forms (cddr forms) (cdr forms))
        !            57:               (return-form `(cons ,(cadr forms) ,(car forms))
        !            58:                             `(cons ,(car forms) ,return-form)))
        !            59:              ((null forms) return-form))))
        !            60: 
        !            61: (defmacro ttf (&rest l) `(list* . , l))
        !            62: 
        !            63: 
        !            64: ;; lexpr-funcall is a cross between apply and funcall.  the last arguments
        !            65: ;; is a list of the rest of the arguments
        !            66: ;; this is now in Franz Opus 38.35
        !            67: ;; (defmacro lexpr-funcall (func &rest args)
        !            68: ;;    `(apply ,func (list* ,@args)))
        !            69: 
        !            70: ; contents of the file libmax;macros  all of these functions are
        !            71: ; (by default) in maclisp
        !            72: ;; (if x p q1 q2 ...) --> (cond (x p) (t q1 q2 ...))
        !            73: ;; it is important that (if nil <form>) returns nil as macsyma code depends
        !            74: ;; upon this in places.  see also ifn in libmax;maxmac.
        !            75: ; in Franz Lisp, opus 38.36 and on
        !            76: ;(defmacro if (predicate then &rest else)
        !            77: ;        (cond ((null else) `(cond (,predicate ,then)))
        !            78: ;              (t `(cond (,predicate ,then) (t . ,else)))))
        !            79: 
        !            80: ;; let, let*, list* are now a part of multics lisp.  nobody should miss
        !            81: ;; the code commented out below.
        !            82: ;; (let ((a 3) (b) c) stuff) --> ((lambda (a b c) stuff) 3 nil nil)
        !            83: ;; (let* ((a 3) (b 4)) stuff) --> ((lambda (a) ((lambda (b) stuff) 4)) 3)
        !            84: 
        !            85: ;; (push x s) --> (setq s (cons x s))
        !            86: ; in franz
        !            87: ;(defmacro push (object list) `(setf ,list (cons ,object ,list)))
        !            88: 
        !            89: ;; (pop s) -->   (prog1 (car s) (setf s (cdr s)))
        !            90: ;; (pop s v) --> (prog1 (setf v (car s)) (setf s (cdr s)))
        !            91: ;; this relies on the fact that setf returns the value stored.
        !            92: 
        !            93: ;(defmacro pop (list &optional (into nil into-p))
        !            94: ;  (cond (into-p `(prog1 (setf ,into (car ,list))
        !            95: ;                        (setf ,list (cdr ,list))))
        !            96: ;        (t `(prog1 (car ,list)
        !            97: ;                   (setf ,list (cdr ,list))))))
        !            98: 
        !            99: ;; (for i m n . body) will evaluate body with i bound to m,m+1,...,n-1
        !           100: ;; sequentially.  (for i 0 n . body) --> (dotimes (i n) . body)
        !           101: 
        !           102: (defmacro for (var start stop . body)
        !           103:           `(do ,var ,start (1+ ,var) (= ,var ,stop) ,@body))
        !           104: 
        !           105: ; these were grabbed from lspsrc;umlmac.5
        !           106: (defmacro when (p . c) `(cond (,p . ,c)))
        !           107: (defmacro unless (p . c) `(cond ((not ,p) . ,c)))
        !           108: 
        !           109: 
        !           110: (defmacro if-for-maclisp-else-lispm (&rest ll) (car ll))
        !           111: 
        !           112: (defmacro logand (&rest forms) `(boole 1 . ,forms))
        !           113: (defmacro logior (&rest forms) `(boole 7 . ,forms))
        !           114: (defmacro logxor (&rest forms) `(boole 6 . ,forms))
        !           115: (defmacro lognot (n) `(boole 10. ,n -1))
        !           116: (defmacro bit-test (&rest forms) `(not (zerop (boole 1 . ,forms))))
        !           117: (defmacro bit-set (x y) `(boole 7 ,x ,y))
        !           118: (defmacro bit-clear (x y) `(boole 2 ,x ,y))
        !           119: 
        !           120: ;; (<= a b) --> (not (> a b))
        !           121: ;; (<= a b c) --> (not (or (> a b) (> b c)))
        !           122: ;; funny arglist to check for correct number of arguments.
        !           123: 
        !           124: (defmacro <= (arg1 arg2 &rest rest &aux result)
        !           125:   (setq rest (list* arg1 arg2 rest))
        !           126:   (do l rest (cdr l) (null (cdr l))
        !           127:       (push `(> ,(car l) ,(cadr l)) result))
        !           128:   (cond ((null (cdr result)) `(not ,(car result)))
        !           129:        (t `(not (or . ,(nreverse result))))))
        !           130: 
        !           131: ;; (>= a b) --> (not (< a b))
        !           132: ;; (>= a b c) --> (not (or (< a b) (< b c)))
        !           133: ;; funny arglist to check for correct number of arguments.
        !           134: 
        !           135: (defmacro >= (arg1 arg2 &rest rest &aux result)
        !           136:   (setq rest (list* arg1 arg2 rest))
        !           137:   (do l rest (cdr l) (null (cdr l))
        !           138:       (push `(< ,(car l) ,(cadr l)) result))
        !           139:   (cond ((null (cdr result)) `(not ,(car result)))
        !           140:        (t `(not (or . ,(nreverse result))))))
        !           141: 
        !           142: 
        !           143: 
        !           144: (defmacro psetq (var value . rest)
        !           145:   (cond (rest `(setq ,var (prog1 ,value (psetq . ,rest))))
        !           146:        (t `(setq ,var ,value))))
        !           147: 
        !           148:  
        !           149: ;; (dotimes (i n) body) evaluates body n times, with i bound to 0, 1, ..., n-1.
        !           150: ;; (dolist (x l) body) successively binds x to the elements of l, and evaluates
        !           151: ;; body each time.
        !           152: 
        !           153: ;; things to beware of:
        !           154: ;; [1] this won't work for count being a bignum.
        !           155: ;; [2] if count is a symbol, somebody could clobber its value inside the body.
        !           156: ;; [3] somebody inside of body could reference **count**.
        !           157: 
        !           158: (defmacro dotimes ((var count) . body)
        !           159:   (if (or (fixp count) (symbolp count))
        !           160:       `(do ((,var 0 (1+ ,var)))
        !           161:           ((>= ,var ,count))
        !           162:           (declare (fixnum ,var))
        !           163:           . ,body)
        !           164:       `(do ((,var 0 (1+ ,var))
        !           165:            (**count** ,count))
        !           166:           ((>= ,var **count**))
        !           167:           (declare (fixnum ,var **count**))
        !           168:           . ,body)))
        !           169: 
        !           170: (defmacro dolist ((var list) . body)
        !           171:   `(do ((**list** ,list (cdr **list**))
        !           172:        (,var))
        !           173:        ((null **list**))
        !           174:        (setq ,var (car **list**))
        !           175:        . ,body))
        !           176: 
        !           177: 
        !           178: ;; symbolconc is the same as concat in franz
        !           179: ;
        !           180: (defmacro symbolconc (&rest args) `(concat ,@args))
        !           181: 
        !           182: 
        !           183: ;-- these functions are from /usr/lib/lisp/lmhacks on the mit-vax
        !           184: 
        !           185: ;;  This file contains miscellaneous functions and macros that 
        !           186: ;;  ZetaLisp users often find useful
        !           187: 
        !           188: (declare (macros t))
        !           189: 
        !           190: (defmacro macro (name argl &body body)
        !           191:   `(def ,name (macro ,argl ,@body)))
        !           192: 
        !           193: (defun gcd (a b)
        !           194:   (or (plusp a)
        !           195:       (setq a (minus a)))
        !           196:   (or (plusp b)
        !           197:       (setq b (minus b)))
        !           198:   (do ((a a b)
        !           199:        (b b (remainder a b)))
        !           200:       ((zerop b)
        !           201:        a)))
        !           202: 
        !           203: (defmacro first (a) `(car ,a))
        !           204: (defmacro second (a) `(cadr ,a))
        !           205: (defmacro third (a) `(caddr ,a))
        !           206: (defmacro fourth (a) `(cadddr ,a))
        !           207: (defmacro fifth (a) `(car (cddddr ,a)))
        !           208: (defmacro sixth (a) `(cadr (cddddr ,a)))
        !           209: (defmacro seventh (a) `(caddr (cddddr ,a)))
        !           210: 
        !           211: (defmacro rest1 (list) `(cdr ,list))
        !           212: (defmacro rest2 (list) `(cddr ,list))
        !           213: (defmacro rest3 (list) `(cdddr ,list))
        !           214: (defmacro rest4 (list) `(cddddr ,list))
        !           215: 
        !           216: (defmacro copylist (list) `(append ,list nil))
        !           217: (defmacro copytree (list) `(subst nil nil ,list))
        !           218: 
        !           219: (defun circular-list (&rest elements)
        !           220:   (setq elements (copylist elements))
        !           221:   (rplacd (last elements) elements)
        !           222:   elements)
        !           223: 
        !           224: (defun butlast (x)
        !           225:   (cond ((null (cdr x)) nil)
        !           226:        (t (cons (car x) (butlast (cdr x))))))
        !           227: 
        !           228: (defun find-position-in-list (item list)
        !           229:   (do ((i 0 (1+ i)))
        !           230:       ((null list) nil)
        !           231:     (if (eq (car list) item)
        !           232:        (return i)
        !           233:        (setq list (cdr list)))))
        !           234: 
        !           235: (defun find-postion-in-list-equal (item list)
        !           236:   (do ((i 0 (1+ i)))
        !           237:       ((null list) nil)
        !           238:     (if (equal (car list) item)
        !           239:        (return i)
        !           240:        (setq list (cdr list)))))
        !           241: 
        !           242: (defun mem (pred item list)
        !           243:   (do ()
        !           244:       ((null list) nil)
        !           245:       (if (funcall pred item (car list))
        !           246:          (return list))
        !           247:       (setq list (cdr list))))
        !           248: 
        !           249: 
        !           250: 
        !           251: ;--- remq is in common2.l
        !           252: 
        !           253: 
        !           254: 
        !           255: (defun rem (pred item list &optional (cnt -1))
        !           256:   (let ((head '())
        !           257:        (tail nil))
        !           258:     (do ((l list (cdr l))
        !           259:         (newcell))
        !           260:        ((null l) head)
        !           261:       (cond ((or (funcall pred (car l) item)
        !           262:                 (zerop cnt))
        !           263:             (setq newcell (list (car l)))
        !           264:             (cond ((null head) (setq head newcell))
        !           265:                   (t (rplacd tail newcell)))
        !           266:             (setq tail newcell))
        !           267:            (t (setq cnt (1- cnt)))))))
        !           268: 
        !           269: (defun rem-if (pred list)
        !           270:   (let ((head '())
        !           271:        (tail nil))
        !           272:     (do ((l list (cdr l))
        !           273:         (newcell))
        !           274:        ((null l) head)
        !           275:       (cond ((not (funcall pred (car l)))
        !           276:             (setq newcell (list (car l)))
        !           277:             (cond ((null head) (setq head newcell))
        !           278:                   (t (rplacd tail newcell)))
        !           279:             (setq tail newcell))))))
        !           280: 
        !           281: (defun rem-if-not (pred list)
        !           282:   (let ((head '())
        !           283:        (tail nil))
        !           284:     (do ((l list (cdr l))
        !           285:         (newcell))
        !           286:        ((null l) head)
        !           287:       (cond ((funcall pred (car l))
        !           288:             (setq newcell (list (car l)))
        !           289:             (cond ((null head) (setq head newcell))
        !           290:                   (t (rplacd tail newcell)))
        !           291:             (setq tail newcell))))))
        !           292: 
        !           293: (make-equivalent subset rem-if-not)
        !           294: (make-equivalent subset-not rem-if)
        !           295: 
        !           296: (defun del (pred item list &optional (cnt -1))
        !           297:   (let ((ret (cons nil list)))
        !           298:     (do ((list ret))
        !           299:        ((null (cdr list))
        !           300:         (cdr ret))
        !           301:       (cond ((and (funcall pred item (second list))
        !           302:                 (not (zerop cnt)))
        !           303:             (setq cnt (1- cnt))
        !           304:             (rplacd list (cddr list)))
        !           305:            (t (setq list (cdr list)))))))
        !           306: 
        !           307: (defun del-if (pred list)
        !           308:   (let ((ret (cons nil list)))
        !           309:     (do ((list ret))
        !           310:        ((null (cdr list))
        !           311:         (cdr ret))
        !           312:        (if (funcall pred (second list))
        !           313:            (rplacd list (cddr list))
        !           314:            (setq list (cdr list))))))
        !           315: 
        !           316: (defun del-if-not (pred list)
        !           317:   (let ((ret (cons nil list)))
        !           318:     (do ((list ret))
        !           319:        ((null (cdr list))
        !           320:         (cdr ret))
        !           321:        (if (not (funcall pred (second list)))
        !           322:            (rplacd list (cddr list))
        !           323:            (setq list (cdr list))))))
        !           324: 
        !           325: (defun some (forms pred &optional step-function)
        !           326:   (and (not (null forms))
        !           327:        (if (funcall pred (car forms))
        !           328:           forms
        !           329:           (some (if (null step-function)
        !           330:                     (cdr forms)
        !           331:                     (funcall step-function forms))
        !           332:                 pred
        !           333:                 step-function))))
        !           334: 
        !           335: (defun every (forms pred &optional step-function)
        !           336:   (or (null forms)
        !           337:       (and (funcall pred (car forms))
        !           338:           (every (if (null step-function)
        !           339:                      (cdr forms)
        !           340:                      (funcall step-function forms))
        !           341:                  pred
        !           342:                  step-function))))
        !           343: 
        !           344: (defmacro pairp (x) `(dtpr ,x))
        !           345: 
        !           346: (defun tailp (subset set)
        !           347:   (do ((s set (cdr s)))
        !           348:       ((null s) nil)
        !           349:       (cond ((eq s subset) (return t)))))
        !           350: 
        !           351: ; defunp
        !           352: ; like defun except it's an implicit prog
        !           353: ; expands
        !           354: ;  (defunp fn (args) form1 form2 ... formn)
        !           355: ; into
        !           356: ;  (defun fn (args) (prog () form1 form2 ... (return (formn))))
        !           357: ; and hence allows returns in the middle of "defun"'s
        !           358: ; If original defun body is just one form (eg, let, cond, etc.)
        !           359: ; return is wrapped around the whole thing.
        !           360: ;
        !           361: 
        !           362: (defmacro defunp (fn arglist . body)
        !           363:   `(defun ,fn ,arglist
        !           364:      (prog ()
        !           365:        ,@(let ((bodyrev (reverse body)))
        !           366:              (nreconc (cdr bodyrev) 
        !           367:                       (cond ((eq 'return (caar bodyrev))
        !           368:                              ; last form is already a return
        !           369:                              `(,(car bodyrev)))
        !           370:                             (t `((return ,(car bodyrev))))))))))
        !           371: 
        !           372: (defmacro let-globally (vars-values . body)
        !           373:   (let ((temp-vars (mapcar #'(lambda (q) (gensym)) vars-values)))
        !           374:     `(progn ((lambda ,temp-vars ,@(mapcar #'(lambda (var-value value)
        !           375:                                              `(setq ,(car var-value) ,value))
        !           376:                                          vars-values temp-vars))
        !           377:              ,@(mapcar #'cadr vars-values))
        !           378:            ,@body)))
        !           379: 
        !           380: (defmacro local-declare (dcls . body)
        !           381:     `(progn 'compile ,@(mapcar #'(lambda (x) `(declare ,x)) dcls) ,@body))
        !           382: 
        !           383: (defmacro defconst (variable &optional (initial-value nil iv-p) documentation)
        !           384:   documentation ;; ignored for now.
        !           385:   (if iv-p `(progn 'compile
        !           386:                   (eval-when (eval compile load)
        !           387:                              (declare (special ,variable)))
        !           388:                   (setq ,variable ,initial-value))
        !           389:       `(eval-when (eval compile load)
        !           390:                  (declare (special ,variable)))))
        !           391: 
        !           392: (defmacro check-arg (var-name predicate description)
        !           393:   `(if (not ,(if (atom predicate)
        !           394:                 `(,predicate ,var-name)
        !           395:                 predicate))
        !           396:        (ferror t "The argument ~S was ~S, which is not ~A.~%"
        !           397:               ',var-name ,var-name ,description)))
        !           398: 
        !           399: (defmacro check-arg-type (var-name type-name &optional description)
        !           400:   `(if (not (typep ,var-name ,type-name)
        !           401:        (ferror t "The argument ~s was ~S, which is not ~A~A.~%"
        !           402:               ',var-name ,var-name
        !           403:               ,(if (null description) " a" "")
        !           404:               ,(if (null description) type-name description)))))
        !           405: 
        !           406: ;;; Defsubst
        !           407: 
        !           408: (defmacro defsubst (function-spec lambda-list &body body)
        !           409:   `(progn 'compile
        !           410:      (defun ,function-spec ,lambda-list ,@body)
        !           411:      (defcmacro ,function-spec ,lambda-list
        !           412:        (sublis (list ,@(do ((v lambda-list (cdr v))
        !           413:                            (r nil (cons `(cons ',(car v) ,(car v)) r)))
        !           414:                         ((null v) (nreverse r))))
        !           415:               ',(if (null (cdr body)) (car body)
        !           416:                    `(progn . ,body))))
        !           417:      ',function-spec))
        !           418: 
        !           419: ;--- ^ :: fixnum expt
        !           420: (defun ^ (x y)
        !           421:   (expt x y))
        !           422: 
        !           423: (putprop 'machacks t 'version)

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