Return to lmhacks.l CVS log

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

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

1.1     ! root        1: (setq rcs-lmhacks-
        !             2:    "$Header: lmhacks.l,v 1.2 83/08/15 22:32:31 jkf Exp $")
        !             3: 
        !             4: ;;  This file contains miscellaneous functions and macros that 
        !             5: ;;  ZetaLisp users often find useful
        !             6: 
        !             7: 
        !             8: ;;;  (c) Copyright 1982 Massachusetts Institute of Technology 
        !             9: 
        !            10: ;; This is a simple multiple value scheme based on the one implemented
        !            11: ;; in MACLISP.  It doesn't clean up after its self properly, so if
        !            12: ;; you ask for multiple values, you will get them regardless of whether
        !            13: ;; they are returned.
        !            14: 
        !            15: (environment-maclisp (compile eval) (files struct flavorm))
        !            16: 
        !            17: (declare (macros t))
        !            18: 
        !            19: (defvar si:argn () "Number of arguments returned by last values")
        !            20: (defvar si:arg2 () "Second return value")
        !            21: (defvar si:arg3 () "Third return value")
        !            22: (defvar si:arg4 () "Fourth return value")
        !            23: (defvar si:arg5 () "Fifth return value")
        !            24: (defvar si:arg6 () "Sixth return value")
        !            25: (defvar si:arg7 () "Seventh return value")
        !            26: (defvar si:arg8 () "Eigth return value")
        !            27: (defvar si:arglist () "Additional return values after the eigth")
        !            28: 
        !            29: (defvar si:return-registers
        !            30:   '(si:arg2 si:arg3 si:arg4 si:arg5 si:arg6 si:arg7 si:arg8))
        !            31: 
        !            32: (defmacro values (&rest values)
        !            33:   `(prog2 (setq si:argn ,(length values))
        !            34:          ,(first values)
        !            35:          ,@(do ((vals (cdr values) (cdr vals))
        !            36:                 (regs si:return-registers (cdr regs))
        !            37:                 (forms))
        !            38:                (nil)
        !            39:              (cond ((null vals)
        !            40:                     (return (reverse forms)))
        !            41:                    ((null regs)
        !            42:                     (return
        !            43:                      `(,@(reverse forms)
        !            44:                        (setq si:arglist (list ,@vals)))))
        !            45:                    (t (push `(setq ,(car regs) ,(car vals))
        !            46:                             forms))))))
        !            47: 
        !            48: (defun values-list (list)
        !            49:   (setq si:argn (length list))
        !            50:   (do ((vals (cdr list) (cdr vals))
        !            51:        (regs si:return-registers (cdr regs)))
        !            52:       ((null regs)
        !            53:        (if (not (null vals))
        !            54:           (setq si:arglist vals))
        !            55:        (car list))
        !            56:     (set (car regs) (car vals))))
        !            57: 
        !            58: (defmacro multiple-value (vars form)
        !            59:   `(progn
        !            60:      ,@(if (not (null (car vars)))
        !            61:          `((setq ,(car vars) ,form)
        !            62:            (if (< si:argn 1) (setq ,(car vars) nil)))
        !            63:          `(,form))
        !            64:      ,@(do ((vs (cdr vars) (cdr vs))
        !            65:            (regs si:return-registers (cdr regs))
        !            66:            (i 2 (1+ i))
        !            67:            (forms))
        !            68:           (nil)
        !            69:         (cond ((null vars)
        !            70:                (return (reverse forms)))
        !            71:               ((null regs)
        !            72:                (return
        !            73:                 (do ((vs vs (cdr vs)))
        !            74:                     ((null vs) (nreverse forms))
        !            75:                   (and (not (null (car vs)))
        !            76:                        (push
        !            77:                         `(setq ,(car vs)
        !            78:                                (prog1
        !            79:                                 (if (not (> ,i si:argn))
        !            80:                                     (car si:arglist))
        !            81:                                 (setq si:arglist (cdr si:arglist))))
        !            82:                         forms)))))
        !            83:               ((not (null (car vs)))
        !            84:                (push `(setq ,(car vs) (if (not (> ,i si:argn)) ,(car regs))
        !            85:                             ,(car regs) nil)
        !            86:                      forms))))))
        !            87: 
        !            88: (defmacro multiple-value-bind (vars form &rest body)
        !            89:   `(let ,vars
        !            90:        (multiple-value ,vars ,form)
        !            91:        ,@body))
        !            92: 
        !            93: (defmacro multiple-value-list (form)
        !            94:   `(multiple-value-list-1 ,form))
        !            95: 
        !            96: (defun multiple-value-list-1 (si:arg1)
        !            97:   (cond ((= 0 si:argn) ())
        !            98:        ((= 1 si:argn)
        !            99:         (list si:arg1))
        !           100:        ((= 2 si:argn)
        !           101:         (list si:arg1 si:arg2))
        !           102:        ((= 3 si:argn)
        !           103:         (list si:arg1 si:arg2 si:arg3))
        !           104:        ((= 4 si:argn)
        !           105:         (list si:arg1 si:arg2 si:arg3 si:arg4))
        !           106:        ((= 5 si:argn)
        !           107:         (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5))
        !           108:        ((= 6 si:argn)
        !           109:         (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6))
        !           110:        ((= 7 si:argn)
        !           111:         (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
        !           112:               si:arg7))
        !           113:        ((= 8 si:argn)
        !           114:         (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
        !           115:               si:arg7 si:arg8))
        !           116:        ((> si:argn 8)
        !           117:         (rplacd (nthcdr (- si:argn 9) si:arglist) nil)
        !           118:         (list* si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
        !           119:                si:arg7 si:arg8 si:arglist))
        !           120:        (t (ferror () "Internal error, si:argn = ~D" si:argn))))
        !           121: 
        !           122: (defun union (set &rest others)
        !           123:   (loop for s in others
        !           124:        do (loop for elt in s
        !           125:                 unless (memq elt set)
        !           126:                 do (push elt set))
        !           127:        finally (return set)))
        !           128: 
        !           129: (defun make-list (length &rest options &aux (iv))
        !           130:   (loop for (key val) on options by #'cddr
        !           131:        do (selectq key
        !           132:             (:initial-value
        !           133:                (setq iv val))
        !           134:             (:area)
        !           135:             (otherwise
        !           136:              (error "Illegal parameter to make-list" key))))
        !           137:   (loop for i from 1 to length collect iv))
        !           138: 
        !           139: ;; si:printing-random-object
        !           140: ;; A macro for aiding in the printing of random objects.
        !           141: ;; This macro generates a form which: (by default) includes the virtual 
        !           142: ;; address in the printed representation.
        !           143: ;; Options are :NO-POINTER to suppress the pointer
        !           144: ;;             :TYPEP princs the typep of the object first.
        !           145: 
        !           146: ;; Example:
        !           147: ;; (DEFSELECT ((:PROPERTY HACKER :NAMED-STRUCTURE-INVOKE))
        !           148: ;;   (:PRINT-SELF (HACKER STREAM IGNORE IGNORE)
        !           149: ;;     (SI:PRINTING-RANDOM-OBJECT (HACKER STREAM :TYPEP)
        !           150: ;;       (PRIN1 (HACKER-NAME HACKER) STREAM))))
        !           151: ;; ==> #<HACKER /"MMcM/" 6172536765>
        !           152: 
        !           153: (defmacro si:printing-random-object ((object stream . options) &body body)
        !           154:   (let ((%pointer t)
        !           155:        (typep nil))
        !           156:     (do ((l options (cdr l)))
        !           157:        ((null l))
        !           158:       (selectq (car l)
        !           159:        (:no-pointer (setq %pointer nil))
        !           160:        (:typep (setq typep t))
        !           161:        (:fastp (setq l (cdr l)))               ; for compatibility sake
        !           162:        (otherwise
        !           163:         (ferror nil "~S is an unknown keyword in si:printing-random-object"
        !           164:                 (car l)))))
        !           165:     `(progn
        !           166:        (patom "#<" ,stream)
        !           167:        ,@(and typep
        !           168:              `((patom (:typep ,object) ,stream)))
        !           169:        ,@(and typep body
        !           170:              `((patom " " ,stream)))
        !           171:        ,@body
        !           172:        ,@(and %pointer
        !           173:              `((patom " " ,stream)
        !           174:                (patom (maknum ,object) ,stream)))
        !           175:        (patom ">" ,stream)
        !           176:        ,object)))
        !           177: 
        !           178: (defun named-structure-p (x &aux symbol)
        !           179:   (cond ((or (and (hunkp x) (atom (setq symbol (cxr 0 x))))
        !           180:             (and (vectorp x)
        !           181:                  (setq symbol (or (and (atom (vprop x)) (vprop x))
        !           182:                                   (and (dtpr (vprop x))
        !           183:                                        (atom (car (vprop x)))
        !           184:                                        (car (vprop x)))))))
        !           185:                                  
        !           186:         (if (get symbol 'defstruct-description)
        !           187:             symbol))))
        !           188: 
        !           189: (defun named-structure-symbol (x)
        !           190:   (or (named-structure-p x)
        !           191:       (ferror () "~S was supposed to have been a named structure."
        !           192:              x)))
        !           193: 
        !           194: (declare (localf named-structure-invoke-internal))
        !           195: 
        !           196: (defun named-structure-invoke (operation struct &rest args)
        !           197:   (named-structure-invoke-internal operation struct args t))
        !           198: 
        !           199: (defun named-structure-invoke-carefully (operation struct &rest args)
        !           200:   (named-structure-invoke-internal operation struct args nil))
        !           201: 
        !           202: (defun named-structure-invoke-internal (operation struct args error-p)
        !           203:    (let (symbol fun)
        !           204:       (setq symbol (named-structure-symbol struct))
        !           205:       (if (setq fun (get symbol ':named-structure-invoke))
        !           206:         then (lexpr-funcall fun operation struct args)
        !           207:         else (and error-p
        !           208:                   (ferror ()
        !           209:                           "No named structure invoke function for ~S"
        !           210:                           struct)))))
        !           211: 
        !           212: (defmacro defselect ((function-spec default-handler no-which-operations)
        !           213:                     &rest args)
        !           214:   (let ((name (intern (gensym)))
        !           215:        fun-name)
        !           216:     `(progn 'compile
        !           217:        (defun ,(if (eq (car function-spec) ':property)
        !           218:                   (cdr function-spec)
        !           219:                   (ferror () "Can't interpret ~S defselect function spec"
        !           220:                                  function-spec))
        !           221:              (operation &rest args &aux temp)
        !           222:         (if (setq temp (gethash operation (get ',name 'select-table)))
        !           223:             (lexpr-funcall temp args)
        !           224:             ,(if default-handler
        !           225:                  `(lexpr-funcall ,default-handler operation args)
        !           226:                  `(ferror () "No handler for the ~S method of ~S"
        !           227:                           operation ',function-spec))))
        !           228:        (setf (get ',name 'select-table) (make-hash-table))
        !           229:        ,@(do ((args args (cdr args))
        !           230:             (form)
        !           231:             (forms nil))
        !           232:            ((null args) (nreverse forms))
        !           233:          (setq form (car args))
        !           234:          (cond ((atom (cdr form))
        !           235:                 (setq fun-name (cdr form)))
        !           236:                (t (setq fun-name
        !           237:                         (intern (concat name (if (atom (car form)) (car form)
        !           238:                                                  (caar form)))))
        !           239:                   (push `(defun ,fun-name ,@(cdr form)) forms)))
        !           240:          (if (atom (car form))
        !           241:              (push `(puthash ',(car form) ',fun-name
        !           242:                              (get ',name 'select-table))
        !           243:                    forms)
        !           244:              (mapc #'(lambda (q)
        !           245:                        (push `(puthash ',q ',fun-name
        !           246:                                        (get ',name 'select-table))
        !           247:                              forms))
        !           248:                    (car form))))
        !           249:        ,@(and (not no-which-operations)
        !           250:              `((defun ,(setq fun-name (intern
        !           251:                                        (concat name '-which-operations)))
        !           252:                       (&rest args)
        !           253:                  '(:which-operations ,@(loop for form in args
        !           254:                                              appending (if (atom (car form))
        !           255:                                                            (list (car form))
        !           256:                                                            (car form)))))
        !           257:                (puthash ':which-operations ',fun-name
        !           258:                         (get ',name 'select-table))))
        !           259:        ',function-spec)))
        !           260: 
        !           261: (defun :typep (ob &optional (type nil) &aux temp)
        !           262:   (cond ((instancep ob)
        !           263:         (instance-typep ob type))
        !           264:        ((setq temp (named-structure-p ob))
        !           265:         (if (null type) temp
        !           266:             (if (eq type temp) t
        !           267:                 (memq type (nth 11. (get temp 'defstruct-description))))))
        !           268:        ((hunkp ob)
        !           269:         (if (null type) 'hunk (eq type 'hunk)))
        !           270:        ((null type)
        !           271:         (funcall 'typep ob))
        !           272:        (t (eq type (funcall 'typep ob)))))
        !           273: 
        !           274: (defun send-internal (object message &rest args)
        !           275:   (declare (special .own-flavor. self))
        !           276:   (lexpr-funcall (if (eq self object)
        !           277:                     (or (gethash message
        !           278:                                  (flavor-method-hash-table .own-flavor.))
        !           279:                         (flavor-default-handler .own-flavor.))
        !           280:                     object)
        !           281:                 message args))
        !           282: 
        !           283: ;; New printer
        !           284: 
        !           285: (declare (special poport prinlevel prinlength top-level-print))
        !           286: 
        !           287: (defun zprint (x &optional (stream poport))
        !           288:        (zprin1 x stream)
        !           289:        't)
        !           290: 
        !           291: (defun zprinc (x &optional (stream poport))
        !           292:        (zprin1a x stream () (or prinlevel -1)))
        !           293: 
        !           294: (defun zprin1 (x &optional (stream poport))
        !           295:        (zprin1a x stream 't (or prinlevel -1)))
        !           296: 
        !           297: (defun zprin1a (ob stream slashifyp level &aux temp)
        !           298:   (cond ((null ob) (patom "()" stream))
        !           299:        ((setq temp (named-structure-p ob))
        !           300:         (or (named-structure-invoke-carefully ':print-self ob stream
        !           301:                                                level slashifyp)
        !           302:             (si:printing-random-object (ob stream :typep))))
        !           303:        ((instancep ob)
        !           304:         (if (get-handler-for ob ':print-self)
        !           305:             (send ob ':print-self stream)
        !           306:             (si:printing-random-object (ob stream :typep))))
        !           307:         ((atom ob)
        !           308:         (if slashifyp (xxprint ob stream)
        !           309:             (patom ob stream)))
        !           310:        ((dtpr ob) (zprint-list ob stream slashifyp (1- level)))
        !           311:        ((hunkp ob) (zprint-hunk ob stream slashifyp (1- level)))
        !           312:        ((= level 0)
        !           313:         (patom "&" stream))
        !           314:        (t
        !           315:         (if slashifyp (xxprint ob stream)
        !           316:             (patom ob stream))))
        !           317:   't)
        !           318: 
        !           319: (defun zprint-list (l stream slashifyp level)
        !           320:        (tyo #/( stream)
        !           321:        (do ((l l (cdr l))
        !           322:            (i (or prinlength -1) (1- i))
        !           323:            (first t nil))
        !           324:           ((not (dtpr l))
        !           325:            (cond ((not (null l))
        !           326:                   (patom " . " stream)
        !           327:                   (zprin1a l stream slashifyp level)))
        !           328:            't)
        !           329:            (cond ((= i 0)
        !           330:                  (patom " ..." stream)
        !           331:                  (return 't)))
        !           332:           (if (not first)
        !           333:               (tyo #/  stream))
        !           334:           (zprin1a (car l) stream slashifyp level))
        !           335:        (tyo #/) stream))
        !           336: 
        !           337: (defun zprint-hunk (l stream slashifyp level)
        !           338:        (tyo #/{ stream)
        !           339:        (do ((i 0 (1+ i))
        !           340:            (lim (hunksize l))
        !           341:            (first t nil))
        !           342:           ((= i lim)
        !           343:            't)
        !           344:            (cond ((and (not (null prinlength)) (not (< i prinlength)))
        !           345:                  (patom " ..." stream)
        !           346:                  (return 't)))
        !           347:           (if (not first)
        !           348:               (tyo #/  stream))
        !           349:           (zprin1a (cxr i l) stream slashifyp level))
        !           350:        (tyo #/} stream))
        !           351: 
        !           352: (eval-when (load eval)
        !           353:    (putd 'xxprint (getd 'print))
        !           354:    (putd 'xxprinc (getd 'princ)))
        !           355: 
        !           356: (defun new-printer ()
        !           357:   (setq top-level-print 'zprint)
        !           358:   (putd 'print (getd 'zprint))
        !           359:   (putd 'prin1 (getd 'zprin1))
        !           360:   't)
        !           361: 
        !           362: (defun old-printer ()
        !           363:   (setq top-level-print 'xxprint)
        !           364:   (putd 'print (getd 'xxprint))
        !           365:   (putd 'princ (getd 'xxprinc))
        !           366:   't)
        !           367: 
        !           368: 
        !           369: 
        !           370: 
        !           371: (putprop 'lmhacks t 'version)

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