home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part07 / macros.l < prev   
Encoding:
Text File  |  1987-08-01  |  25.0 KB  |  764 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26. ;;; Macros global variable definitions, and other random support stuff used
  27. ;;; by the rest of the system.
  28. ;;;
  29. ;;; For simplicity (not having to use eval-when a lot), this file must be
  30. ;;; loaded before it can be compiled.
  31. ;;;
  32.  
  33. (in-package 'pcl :nicknames '(portable-commonloops) :use '(lisp walker))
  34.  
  35. (export '(defclass
  36.       defmethod
  37.       print-object
  38.  
  39.       print-instance
  40.       ndefstruct
  41.       defmeth
  42.       run-super
  43.       make
  44.       initialize
  45.       get-slot
  46.       with
  47.       with*
  48.       class-of
  49.       class-named
  50.       discriminator-named
  51.       class-prototype
  52.       class
  53.       object
  54.  
  55.  
  56.  
  57.       essential-class
  58.       
  59.       class-name
  60.       class-precedence-list
  61.       class-local-supers
  62.       class-local-slots
  63.       class-direct-subclasses
  64.       class-direct-methods
  65.       class-slots
  66.  
  67.  
  68.       essential-discriminator
  69.  
  70.       discriminator-name
  71.       discriminator-methods
  72.       discriminator-discriminating-function
  73.  
  74.       essential-method
  75.  
  76.       method-discriminator
  77.       method-arglist
  78.       method-argument-specifiers            
  79.       method-function
  80.  
  81.       method-equal
  82.  
  83.       discriminator-methods
  84.  
  85.       slotd-name
  86.       slot-missing
  87.  
  88.       define-meta-class
  89.       %make-instance
  90.       %instance-ref
  91.       %instancep
  92.       %instance-meta-class
  93.  
  94.       make-instance
  95.       get-slot
  96.       put-slot
  97.       get-slot-using-class
  98.       optimize-slot-access
  99.       define-class-of-clause
  100.       add-named-class
  101.       class-for-redefinition
  102.       add-class
  103.       supers-changed
  104.       slots-changed
  105.       check-super-meta-class-compatibility
  106.       check-meta-class-change-compatibility
  107.       make-slotd
  108.       compute-class-precedence-list
  109.       walk-method-body
  110.       walk-method-body-form
  111.       optimize-get-slot
  112.       optimize-set-of-get-slot
  113.       variable-lexical-p
  114.       add-named-method
  115.       add-method
  116.       remove-named-method
  117.       remove-method
  118.       find-method
  119.       find-method-internal
  120.       make-discriminating-function
  121.       install-discriminating-function
  122.       no-matching-method
  123.       class-class-precedence-list
  124.       class-local-supers
  125.       class-direct-subclasses
  126.       class-name
  127.       
  128.       )
  129.     (find-package 'pcl))
  130.  
  131. (proclaim '(declaration values            ;I use this so that Zwei can
  132.                         ;remind me what values a
  133.                         ;function returns.
  134.             
  135.             method-function-name    ;This is used so that some
  136.                         ;systems can print the name
  137.                         ;of the method when I am in
  138.                         ;the debugger.
  139.                         ))
  140.  
  141. ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
  142. ;;; in other packages in all CommonLisp implementations, but I will leave it
  143. ;;; to the compiler to optimize into calls to them.
  144. ;;;
  145. ;;; Common Lisp BUG:
  146. ;;;    Some Common Lisps define these in the Lisp package which causes
  147. ;;;    all sorts of lossage.  Common Lisp should explictly specify which
  148. ;;;    symbols appear in the Lisp package.
  149. ;;;    
  150. (defmacro memq (item list) `(member ,item ,list :test #'eq))
  151. (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
  152. (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
  153. (defmacro delq (item list) `(delete ,item ,list :test #'eq))
  154. (defmacro neq (x y) `(not (eq ,x ,y)))
  155.  
  156. (defun make-caxr (n form)
  157.   (if (< n 4)
  158.       `(,(nth n '(car cadr caddr cadddr)) ,form)
  159.       (make-caxr (- n 4) `(cddddr ,form))))
  160.  
  161. (defun make-cdxr (n form)
  162.   (cond ((zerop n) form)
  163.     ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
  164.     (t (make-cdxr (- n 4) `(cddddr ,form)))))
  165.  
  166. (defmacro ignore (&rest vars)
  167.   #+Symbolics `(progn ,.(remove 'ignore vars))
  168.   #-Symbolics `(progn ,@vars))
  169.  
  170. (defun true (&rest ignore) (ignore ignore) t)
  171. (defun false (&rest ignore) (ignore ignore) nil)
  172.  
  173. ;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
  174. ;;; lifted it from there but I am honest.  Not only that but this one is
  175. ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
  176. ;;; like rebuilding Rome.
  177. (defmacro once-only (vars &body body)
  178.   (let ((gensym-var (gensym))
  179.         (run-time-vars (gensym))
  180.         (run-time-vals (gensym))
  181.         (expand-time-val-forms ()))
  182.     (dolist (var vars)
  183.       (push `(if (or (symbolp ,var)
  184.                      (numberp ,var)
  185.                      (and (listp ,var)
  186.               (member (car ,var) '(quote function))))
  187.                  ,var
  188.                  (let ((,gensym-var (gensym)))
  189.                    (push ,gensym-var ,run-time-vars)
  190.                    (push ,var ,run-time-vals)
  191.                    ,gensym-var))
  192.             expand-time-val-forms))    
  193.     `(let* (,run-time-vars
  194.             ,run-time-vals
  195.             (wrapped-body
  196.               ((lambda ,vars . ,body) . ,(reverse expand-time-val-forms))))
  197.        `((lambda ,(nreverse ,run-time-vars)  ,wrapped-body)
  198.          . ,(nreverse ,run-time-vals)))))
  199.  
  200. (defun extract-declarations (body &optional environment)
  201.   (declare (values documentation declares body))
  202.   (let (documentation declares form temp)
  203.     (when (stringp (car body)) (setq documentation (pop body)))
  204.     (loop
  205.       (when (null body) (return))
  206.       (setq form (car body))
  207.       (cond ((and (listp form) (eq (car form) 'declare))
  208.          (push (pop body) declares))
  209. ;        ((and (neq (setq temp (macroexpand form environment)) form)
  210. ;          (listp temp)
  211. ;          (eq (car temp) 'declare))
  212. ;         (pop body)
  213. ;         (push temp declares))
  214.         (t (return))))
  215.     (values documentation declares body)))
  216.  
  217.   ;;   
  218. ;;;;;; FAST-NCONC Lists
  219.   ;;
  220. ;;; These are based on Interlisp's TCONC function.  They are slighlty
  221. ;;; generalized to take either the item to nconc onto the end of the list or
  222. ;;; a cons to add to the end of a list. In addition there is a constructor to
  223. ;;; make fast-nconc-lists and an accessor to get at a fast-nconc-list's real
  224. ;;; list.
  225. (defmacro make-fast-nconc-list ()
  226.   `(let ((fast-nconc-list (cons () (list ()))))
  227.      (rplaca fast-nconc-list (cdr fast-nconc-list))
  228.      fast-nconc-list))
  229.  
  230. (defmacro fast-nconc-list-real-list (fast-nconc-list)
  231.   `(cddr ,fast-nconc-list))
  232.  
  233. (defmacro fast-nconc-cons (fast-nconc-list cons)
  234.   (once-only (fast-nconc-list)
  235.     `(progn (rplacd (car ,fast-nconc-list) ,cons)
  236.             (rplaca ,fast-nconc-list (cdar ,fast-nconc-list)))))
  237.  
  238. (defmacro fast-nconc-item (fast-nconc-list item)
  239.   `(fast-nconc-cons ,fast-nconc-list (cons ,item nil)))
  240.  
  241. #+Lucid
  242. (eval-when (compile load eval)
  243.   (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
  244.  
  245. ; rds 3/8 added -HP and +HP for make-keyword:
  246. #-HP
  247. (defun make-keyword (symbol)
  248.    (intern (symbol-name symbol) '#,(find-package 'keyword)))
  249.  
  250. #+HP
  251. (defun make-keyword (symbol)
  252.    (intern (symbol-name symbol) (find-package 'keyword)))
  253.  
  254. (defun string-append (&rest strings)
  255.   (setq strings (copy-list strings))        ;The explorer can't even
  256.                         ;rplaca an &rest arg?
  257.   (do ((string-loc strings (cdr string-loc)))
  258.       ((null string-loc)
  259.        (apply #'concatenate 'string strings))
  260.     (rplaca string-loc (string (car string-loc)))))
  261.  
  262. (defun symbol-append (sym1 sym2 &optional (package *package*))
  263.   (intern (string-append sym1 sym2) package))
  264.  
  265. (defmacro check-member (place list &key (test #'eql) (pretty-name place))
  266.   (once-only (place list)
  267.     `(or (member ,place ,list :test ,test)
  268.          (error "The value of ~A, ~S is not one of ~S."
  269.                 ',pretty-name ,place ,list))))
  270.  
  271.  
  272.  
  273. ;;; A simple version of destructuring-bind.
  274.  
  275. ;;; This does no more error checking than CAR and CDR themselves do.  Some
  276. ;;; attempt is made to be smart about preserving intermediate values.  It
  277. ;;; could be better, although the only remaining case should be easy for
  278. ;;; the compiler to spot since it compiles to PUSH POP.
  279. ;;;
  280. ;;; Common Lisp BUG:
  281. ;;;    Common Lisp should have destructuring-bind.
  282. ;;;    
  283. (defmacro destructuring-bind (pattern form &body body)
  284.   (multiple-value-bind (ignore declares body)
  285.       (extract-declarations body)
  286.     (multiple-value-bind (setqs binds)
  287.     (destructure pattern form)
  288.       `(let ,binds
  289.      ,@declares
  290.      ,@setqs
  291.      . ,body))))
  292.  
  293. (defun destructure (pattern form)
  294.   (declare (values setqs binds))
  295.   (let ((*destructure-vars* ())
  296.     (setqs ()))
  297.     (declare (special *destructure-vars*))
  298.     (when (not (symbolp form))
  299.       (setq *destructure-vars* '(.destructure-form.)
  300.         setqs (list `(setq .destructure-form. ,form)))
  301.       (setq form '.destructure-form.))
  302.     (values (nconc setqs (nreverse (destructure-internal pattern form)))
  303.         (delete nil *destructure-vars*))))
  304.  
  305. (defun destructure-internal (pattern form)
  306.   ;; When we are called, pattern must be a list.  Form should be a symbol
  307.   ;; which we are free to setq containing the value to be destructured.
  308.   ;; Optimizations are performed for the last element of pattern cases.
  309.   ;; we assume that the compiler is smart about gensyms which are bound
  310.   ;; but only for a short period of time.
  311.   (declare (special *destructure-vars*))
  312.   (let ((gensym (gensym))
  313.     (pending-pops 0)
  314.     (var nil)
  315.     (setqs ()))
  316.     (labels
  317.         ((make-pop (var form pop-into)
  318.        (prog1 
  319.          (cond ((zerop pending-pops)
  320.             `(progn ,(and var `(setq ,var (car ,form)))
  321.                 ,(and pop-into `(setq ,pop-into (cdr ,form)))))
  322.            ((null pop-into)
  323.             (and var `(setq ,var ,(make-caxr pending-pops form))))
  324.            (t
  325.             `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
  326.                 ,(and var `(setq ,var (pop ,pop-into))))))
  327.          (setq pending-pops 0))))
  328.       (do ((pat pattern (cdr pat)))
  329.       ((null pat) ())
  330.     (if (symbolp (setq var (car pat)))
  331.         (progn
  332.           (push var *destructure-vars*)
  333.           (cond ((null (cdr pat))
  334.              (push (make-pop var form ()) setqs))
  335.             ((symbolp (cdr pat))
  336.              (push (make-pop var form (cdr pat)) setqs)
  337.              (push (cdr pat) *destructure-vars*)
  338.              (return ()))
  339.             ((memq var '(nil ignore)) (incf pending-pops))
  340.             ((memq (cadr pat) '(nil ignore))
  341.              (push (make-pop var form ()) setqs)
  342.              (incf pending-pops 1))
  343.             (t
  344.              (push (make-pop var form form) setqs))))
  345.         (progn
  346.           (push `(let ((,gensym ()))
  347.                ,(make-pop gensym form (if (symbolp (cdr pat)) (cdr pat) form))
  348.                ,@(nreverse
  349.                (destructure-internal (if (consp pat) (car pat) pat)
  350.                          gensym)))
  351.             setqs)
  352.           (when (symbolp (cdr pat))
  353.         (push (cdr pat) *destructure-vars*)
  354.         (return)))))
  355.       setqs)))
  356.  
  357. ;;; Iterate is a simple iteration macro.  If CommonLisp had a standard Loop
  358. ;;; macro I wouldn't need this wretched crock.  But what the hell, it seems
  359. ;;; to do most of what I need.  It looks like:
  360. ;;;   (iterate (<control-clause-1> <control-clause-2> ...)
  361. ;;;      . <body>)
  362. ;;;
  363. ;;;  a control clause can be one of:
  364. ;;;   (<var> in <list-form>)  | (<var> in <list-form> by <function>)
  365. ;;;   (<var> on <list-form>)  | (<var> on <list-form> by <function>)
  366. ;;;   (<var> from <initial> to <final>)
  367. ;;;   (<var> from <initial> below <final>)
  368. ;;;   (<var> from <initial> to <final> by <function> | <increment>)
  369. ;;;   (<var> from <initial> below <final> by <function> | <increment>)
  370. ;;;   (<var> = <form>)   <form> is evaluated each time through
  371. ;;;   (<var> = <initial> <subsequent>)
  372. ;;;   
  373. ;;;  inside <body> you are allowed to use:
  374. ;;;    collect
  375. ;;;    join
  376. ;;;    sum
  377.  
  378. (defvar *iterate-result-types* ())
  379.  
  380. (defmacro define-iterate-result-type (name arglist &body body)
  381.   (let ((fn-name
  382.       (if (and (null (cdr body)) (symbolp (car body)))
  383.           (car body)
  384.           (make-symbol (string-append (symbol-name name) " iterate result type")))))
  385.     `(progn
  386.        (let ((existing (assq ',name  *iterate-result-types*)))
  387.      (if existing
  388.          (rplacd existing ',fn-name)
  389.          (push ',(cons name fn-name) *iterate-result-types*)))
  390.        ,(and (not (and (null (cdr body)) (symbolp (car body))))
  391.          `(defun ,fn-name ,arglist . ,body)))))
  392.  
  393. (defmacro iterate (controls &body body)
  394.   #+Xerox (setq body (copy-tree body))
  395.   (let (binds var-init-steps
  396.     pre-end-tests post-end-tests
  397.     pre-bodies post-bodies
  398.     (result-type ()))
  399.     (mapc #'(lambda (control)
  400.           (let ((var (car control))
  401.             (type (cadr control))
  402.             (initial (caddr control))
  403.             (args (cdddr control)))
  404.         (ecase type
  405.           ((in on)
  406.            (let* ((gensym (if (or (eq type 'in) (consp var)) (gensym) var))
  407.               (step `(,(if args (cadr args) 'cdr) ,gensym)))
  408.              (push `(,gensym ,initial ,step) var-init-steps)
  409.              (push `(null ,gensym) pre-end-tests)
  410.              (cond ((listp var)
  411.                 (multiple-value-bind (setqs dbinds)
  412.                 (destructure var (if (eq type 'in) `(car ,gensym) gensym))
  413.                   (setq binds (nconc dbinds binds))
  414.                   (setq pre-bodies (nconc pre-bodies (nreverse setqs)))))
  415.                ((eq type 'in)
  416.                 (push var binds)
  417.                 (push `(setq ,var (car ,gensym)) pre-bodies)))))
  418.           (from
  419.             (let ((gensym (gensym))
  420.               (final
  421.                 (and (memq (car args) '(to below))
  422.                  (if (eq (car args) 'to)
  423.                      (cadr args)
  424.                      `(- ,(cadr args) 1))))
  425.               (step
  426.                 (progn (setq args (member 'by args))
  427.                    (cond ((null args)
  428.                       `(1+ ,var))
  429.                      ((numberp (cadr args))
  430.                       `(+ ,var ,(cadr args)))
  431.                      (t (cadr args))))))
  432.               (push `(,var ,initial ,step) var-init-steps)
  433.               (and final (push `(,gensym ,final) binds))
  434.               (and final (push `(> , var ,gensym) pre-end-tests))))
  435.           (=
  436.             (push `(,var ,initial ,(or (car args) initial))
  437.               var-init-steps))
  438.           )))
  439.       controls)
  440.     (setq body
  441.       (walk-form (cons 'progn body)
  442.              :walk-function
  443.              #'(lambda (form context &aux aux)
  444.              (ignore context)
  445.              (or (and (listp form)
  446.                   (setq aux (assq (car form) *iterate-result-types*))
  447.                   (setq result-type
  448.                     (if (null result-type)
  449.                         (funcall (cdr aux)
  450.                              form nil 'create-result-type)
  451.                         (funcall (cdr aux)
  452.                              form result-type 'check-result-type)))
  453.                   (funcall (cdr aux) form result-type 'macroexpand))
  454.                  form))))
  455.     (let* ((initially (cons 'progn
  456.                 (dolist (tlf body)
  457.                   (when (and (consp tlf) (eq (car tlf) 'initially))
  458.                 (return (prog1 (cdr tlf)
  459.                            (setf (car tlf) 'progn
  460.                              (cdr tlf) ())))))))
  461.        (finally (cons 'progn
  462.               (dolist (tlf body)
  463.                 (when (and (consp tlf) (eq (car tlf) 'finally))
  464.                   (return (prog1 (cdr tlf)
  465.                          (setf (car tlf) 'progn
  466.                            (cdr tlf) ()))))))))
  467.       `(let (,@binds . ,(caddr result-type))
  468.      (iterate-macrolets
  469.        (prog ,(mapcar #'(lambda (x) (list (car x) (cadr x)))
  470.               var-init-steps)
  471.          ,initially
  472.           restart
  473.          (and (or . ,(reverse pre-end-tests))
  474.               (go .iterate_return.))
  475.          (progn . ,(reverse pre-bodies))
  476.          ,body
  477.          (progn . ,(reverse post-bodies))
  478.          (or ,@post-end-tests
  479.              (progn ,@(mapcar #'(lambda (x)
  480.                       (and (cddr x)
  481.                            `(setq ,(car x)
  482.                               ,(caddr x))))
  483.                       var-init-steps)
  484.                 (go restart)))
  485.           .iterate_return.
  486.          ,finally
  487.          (return ,(cadddr result-type))))))))
  488.  
  489. (define-iterate-result-type collect (form result-type op)
  490.   iterate-collect-join)
  491.  
  492. (define-iterate-result-type join (form result-type op)
  493.   iterate-collect-join)
  494.  
  495. (defun iterate-collect-join (form result-type op)
  496.   (ecase op
  497.     (create-result-type
  498.       (let ((gensym (gensym)))
  499.     `(,(car form) ,gensym ((,gensym ())) (nreverse ,gensym))))
  500.     (check-result-type
  501.       (if (memq (car result-type) '(collect join))
  502.       result-type
  503.       (error "Using ~S inside an iterate in which you already used ~S."
  504.          (car form) (car result-type))))
  505.     (macroexpand
  506.       (if (eq (car form) 'collect)
  507.       `(push ,(cadr form) ,(cadr result-type))
  508.       `(setq ,(cadr result-type)
  509.          (append (reverse ,(cadr form)) ,(cadr result-type)))))))
  510.  
  511. (define-iterate-result-type sum (form result-type op)
  512.   (ecase op
  513.     (create-result-type
  514.       (let ((gensym (gensym)))
  515.     `(,(car form) ,gensym ((,gensym 0)) ,gensym)))
  516.     (check-result-type
  517.       (eq (car result-type) 'sum))
  518.     (macroexpand
  519.       `(incf ,(cadr result-type) ,(cadr form)))))
  520.  
  521. (defmacro iterate-macrolets (&body body)
  522.   `(macrolet
  523.      ((until (test)
  524.         `(when ,test (go .iterate_return.)))
  525.       (while (test)
  526.     `(until (not ,test)))
  527.       (initially (&body body)
  528.     (error
  529.       "It is an error for FINALLY to appear other than at top-level~%~
  530.        inside an iterate."))
  531.       (finally (&body ignore)
  532.     (error
  533.       "It is an error for INITIALLY to appear other than at top-level~%~
  534.            inside an iterate."))
  535.       )
  536.      . ,body))
  537.   
  538. ;;;
  539. ;;; Two macros useful for parsing defstructs.
  540. ;;; The first parses slot-description (or lambda-list) style keyword-value
  541. ;;; pairs.  The second, more complicated one, parses defstruct option style
  542. ;;; keyword-value pairs.
  543. ;;;
  544. (defmacro keyword-bind (keywords form &body body)
  545.   `(apply (function (lambda (&key . ,keywords) . ,body)) ,form))
  546.  
  547. ;;;
  548. ;;;   (keyword-parse (<keyword-spec-1> <keyword-spec-2> ..)
  549. ;;;                  form
  550. ;;;      . body)
  551. ;;;
  552. ;;; Where form is a form which will be evaluated and should return the list
  553. ;;; of keywords and values which keyword-parse will parse.  Body will be
  554. ;;; evaluated with the variables specified by the keyword-specs bound.
  555. ;;; Keyword specs look like:
  556. ;;;        <var>
  557. ;;;        (<var> <default>)
  558. ;;;        (<var> <default> <suppliedp var>)
  559. ;;;        (<var> <default> <suppliedp var> <option-1> <val-1> ...)
  560. ;;;
  561. ;;;    The options can be:
  562. ;;;       :allowed     ---  :required   :multiple
  563. ;;;       :return-cdr  ---  t           nil
  564. ;;;       
  565. (defmacro keyword-parse (keywords form &body body)
  566.   ;; This makes an effort to resemble keyword-bind in that the vars are bound
  567.   ;; one at a time so that a default value form can look at the value of a
  568.   ;; previous argument. This is probably more hair than its worth, but what
  569.   ;; the hell, programming is fun.
  570.   (let* ((lambda-list ())
  571.          (supplied-p-gensyms ())
  572.          (value-forms ())
  573.          (entry-var (gensym)))
  574.     (dolist (kw keywords)
  575.       (unless (listp kw) (setq kw (list kw)))      
  576.       (destructuring-bind (var default supplied-p-var . options) kw
  577.         (keyword-bind (presence (allowed ':required) return-cdr) options
  578.           (push var lambda-list)
  579.           (when supplied-p-var
  580.             (push supplied-p-var lambda-list)
  581.             (push (gensym) supplied-p-gensyms))
  582.           (push `(let ((,entry-var (keyword-parse-assq ',(make-keyword var)
  583.                                ,form
  584.                                ',allowed)))
  585.                    (if (null ,entry-var)
  586.                        ,default
  587.                        ;; Insert appropriate error-checking based on the
  588.                        ;; allowed argument.
  589.                        (progn
  590.                        ,(when (null allowed)
  591.                           `(unless (nlistp (car ,entry-var))
  592.                              (error "The ~S keyword was supplied with an ~
  593.                                     argument, it is not allowed to have one."
  594.                                     ',(make-keyword var))))
  595.                        ,(when (eq allowed ':required)
  596.                           `(unless (listp (car ,entry-var))
  597.                              (error
  598.                    "The ~S keyword was supplied without an ~
  599.                                 argument~%when present, this keyword must ~
  600.                                 have an argument."
  601.                                ',(make-keyword var))))
  602.                        (cond ((listp (car ,entry-var))
  603.                               ,(and supplied-p-var
  604.                                     `(setq ,(car supplied-p-gensyms) 't))
  605.                               ,(if return-cdr
  606.                    (if (eq allowed ':multiple)
  607.                        `(mapcar #'cdr ,entry-var)
  608.                        `(cdar ,entry-var))
  609.                    (if (eq allowed ':multiple)
  610.                        `(mapcar #'cadr ,entry-var)
  611.                        `(cadar ,entry-var))))
  612.                              (t
  613.                               ,(and supplied-p-var
  614.                                     `(setq ,(car supplied-p-gensyms)
  615.                        ':presence))
  616.                               ,presence)))))
  617.                 value-forms)
  618.           (when supplied-p-var
  619.             (push (car supplied-p-gensyms) value-forms)))))
  620.     `(let ,supplied-p-gensyms
  621.        ((lambda ,(reverse lambda-list) . ,body) . ,(reverse value-forms)))))
  622.  
  623.  
  624. (defun keyword-parse-assq (symbol list allowed)
  625.   (do ((result nil result)
  626.        (tail list (cdr tail)))
  627.       ((null tail) (nreverse result))
  628.     (if (eq (if (symbolp (car tail)) (car tail) (caar tail)) symbol)
  629.     (if (neq allowed ':multiple)
  630.         (return tail)
  631.         (push (car tail) result)))))
  632.  
  633.   ;;   
  634. ;;;;;; printing-random-thing
  635.   ;;
  636. ;;; Similar to printing-random-object in the lisp machine but much simpler
  637. ;;; and machine independent.
  638. (defmacro printing-random-thing ((thing stream) &body body)
  639.   (once-only (stream)
  640.   `(let ((*print-level* (and (numberp *print-level*) (- *print-level* 1))))
  641.      (progn (princ "#<" ,stream)
  642.             ,@body
  643.         (princ " " ,stream)
  644.         (printing-random-thing-internal ,thing ,stream)
  645.         (princ ">" ,stream)))))
  646.  
  647. (defun printing-random-thing-internal (thing stream)
  648.   (ignore thing stream)
  649.   nil)
  650.  
  651.   ;;   
  652. ;;;;;; 
  653.   ;;
  654.  
  655. (defun capitalize-words (string)
  656.   (let ((string (copy-seq (string string))))
  657.     (declare (string string))
  658.     (do* ((flag t flag)
  659.       (length (length string) length)
  660.       (char nil char)
  661.       (i 0 (+ i 1)))
  662.      ((= i length) string)
  663.       (setq char (elt string i))
  664.       (cond ((both-case-p char)
  665.          (if flag
  666.          (and (setq flag (lower-case-p char))
  667.               (setf (elt string i) (char-upcase char)))
  668.          (and (not flag) (setf (elt string i) (char-downcase char))))
  669.          (setq flag nil))
  670.         ((char-equal char #\-)
  671.          (setq flag t))
  672.         (t (setq flag nil))))))
  673.  
  674.   ;;
  675. ;;;;;; CLASS-NAMED  naming classes.
  676.   ;;
  677. ;;;
  678. ;;; (CLASS-NAMED <name>) returns the class named <name>.  setf can be used
  679. ;;; with class-named to set the class named <name>.  These are "extrinsic"
  680. ;;; names.  Neither class-named nor setf of class-named do anything with the
  681. ;;; name slot of the class, they only lookup and change the association from
  682. ;;; name to class.
  683. ;;; 
  684.  
  685. (defvar *class-name-hash-table* (make-hash-table :test #'eq))
  686.  
  687. (defun class-named (name &optional no-error-p)
  688.   (or (gethash name *class-name-hash-table*)
  689.       (if no-error-p () (error "No class named: ~S." name))))
  690.  
  691. (defsetf class-named (name &optional ignore-damnit) (class)
  692.   `(setf (gethash ,name *class-name-hash-table*) ,class))
  693.  
  694.  
  695. (defvar *discriminator-name-hash-table* (make-hash-table :test #'eq
  696.                              :size 1000))
  697.  
  698. (defun discriminator-named (name)                ;This a function for
  699.   (gethash name *discriminator-name-hash-table*))    ;the benefit of
  700.                                 ;compile-time-define?
  701.  
  702. (defun set-discriminator-named (name new-value)
  703.   (setf (gethash name *discriminator-name-hash-table*) new-value))
  704.  
  705. (defsetf discriminator-named set-discriminator-named)
  706.  
  707. ;;;
  708. ;;; To define a macro which is only applicable in the body of a defmethod,
  709. ;;; use define-method-body-macro.  This macro takes two arguments the name
  710. ;;; of the macro that should be defined in the body of the method and the
  711. ;;; function which should be called to expand calls to that macro.
  712. ;;; 
  713. ;;; Expander-function will be called with 3 arguments:
  714. ;;; 
  715. ;;;   the entire macro form (gotten with &whole)
  716. ;;;   the macroexpand-time-information
  717. ;;;   the environment
  718. ;;;   
  719.  
  720. (defvar *method-body-macros* ())
  721.  
  722. (defmacro define-method-body-macro (name arglist &key global method)
  723.   (when (eq global :error)
  724.     (setq global
  725.       `(progn (warn "~S used outside the body of a method." ',name)
  726.           '(error "~S used outside the body of a method." ',name))))
  727.   (or method
  728.       (error "Have to provide a value for the method-body definition of~%~
  729.               a macro defined with define-method-body-macro."))
  730.   #+KCL (when (memq '&environment arglist)
  731.       ;; In KCL, move &environment to the beginning of the
  732.       ;; arglist since they require that it be there.
  733.       (unless (eq (car arglist) '&environment)
  734.         (do ((loc arglist (cdr loc)))
  735.         ((eq (cadr loc) '&environment)
  736.          (setq arglist (list* (cadr loc) (caddr loc) arglist))
  737.          (setf (cdr loc) (cdddr loc))))))
  738.   (let ((body-expander-function (gensym))
  739.     (parameters (remove lambda-list-keywords arglist
  740.                 :test #'(lambda (x y) (member y x)))))
  741.     `(eval-when (compile load eval)
  742.        ,(and global `(defmacro ,name ,arglist ,global))
  743.        (defun ,body-expander-function
  744.           (macroexpand-time-environment ,@parameters)
  745.      ,method)
  746.      
  747.        (let ((entry (or (assq ',name *method-body-macros*)
  748.             (progn (push (list ',name) *method-body-macros*)
  749.                    (car *method-body-macros*)))))
  750.      (setf (cdr entry) (list ',arglist
  751.                  ',parameters
  752.                  ',body-expander-function))))))
  753.  
  754.   ;;   
  755. ;;;;;; Special variable definitions.
  756.   ;;
  757. ;;; Gets set to its right value once early-defmeths are fixed.
  758. ;;; 
  759. (defvar *error-when-defining-method-on-existing-function* 'bootstrapping
  760.   "If this variable is non-null (the default) defmethod signals an error when
  761.    a method is defined on an existing lisp-function without first calling
  762.    make-specializable on that function.")
  763.  
  764.