/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Diff of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by ram, Sat Oct 19 17:23:05 1991 UTC revision 1.3 by ram, Mon Jun 1 18:38:30 1992 UTC
# Line 46  Line 46 
46               class               class
47               variable-rebinding               variable-rebinding
48               pcl-fast-call               pcl-fast-call
49                 specializer-names
50               ))               ))
51    
52  ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist  ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
# Line 123  Line 124 
124    
125  (eval-when (compile load eval)  (eval-when (compile load eval)
126  (defun extract-declarations (body &optional environment)  (defun extract-declarations (body &optional environment)
127    (declare (values documentation declarations body))    ;;(declare (values documentation declarations body))
128    (let (documentation declarations form)    (let (documentation declarations form)
129      (when (and (stringp (car body))      (when (and (stringp (car body))
130                 (cdr body))                 (cdr body))
# Line 210  Line 211 
211    
212  (eval-when (compile load eval)  (eval-when (compile load eval)
213  (defun destructure (pattern form)  (defun destructure (pattern form)
214    (declare (values setqs binds))    ;;(declare (values setqs binds))
215    (let ((*destructure-vars* ())    (let ((*destructure-vars* ())
216          (setqs ()))          (setqs ()))
217      (declare (special *destructure-vars*))      (declare (special *destructure-vars*))
# Line 308  Line 309 
309  (defmacro if* (condition true &rest false)  (defmacro if* (condition true &rest false)
310    `(if ,condition ,true (progn ,@false)))    `(if ,condition ,true (progn ,@false)))
311    
312    (defmacro dolist-carefully ((var list improper-list-handler) &body body)
313      `(let ((,var nil)
314             (.dolist-carefully. ,list))
315         (loop (when (null .dolist-carefully.) (return nil))
316               (if (consp .dolist-carefully.)
317                   (progn
318                     (setq ,var (pop .dolist-carefully.))
319                     ,@body)
320                   (,improper-list-handler)))))
321    
322    ;;    ;;
323  ;;;;;; printing-random-thing  ;;;;;; printing-random-thing
# Line 350  Line 360 
360               (unless dashes-p (setf (elt string i) #\space)))               (unless dashes-p (setf (elt string i) #\space)))
361              (t (setq flag nil))))))              (t (setq flag nil))))))
362    
363    #-(or lucid kcl)
364    (eval-when (compile load eval)
365    ;(warn "****** Things will go faster if you fix define-compiler-macro")
366    )
367    
368    (defmacro define-compiler-macro (name arglist &body body)
369      #+(or lucid kcl)
370      `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
371            ,name ,arglist
372         ,@body)
373      #-(or kcl lucid)
374      nil)
375    
376    
377  ;;;  ;;;
378  ;;; FIND-CLASS  ;;; FIND-CLASS
# Line 358  Line 381 
381  ;;;  ;;;
382  (defvar *find-class* (make-hash-table :test #'eq))  (defvar *find-class* (make-hash-table :test #'eq))
383    
384  (defun legal-class-name-p (x)  (defun make-constant-function (value)
385    (and (symbolp x)    #'(lambda (object)
386         (not (keywordp x))))        (declare (ignore object))
387          value))
388    
389  (defun find-class (symbol &optional (errorp t) environment)  (defun function-returning-nil (x)
390    (declare (ignore environment))    (declare (ignore x))
391      nil)
392    
393    (defun function-returning-t (x)
394      (declare (ignore x))
395      t)
396    
397    (defmacro find-class-cell-class (cell)
398      `(car ,cell))
399    
400    (defmacro find-class-cell-predicate (cell)
401      `(cdr ,cell))
402    
403    (defmacro make-find-class-cell (class-name)
404      (declare (ignore class-name))
405      '(cons nil #'function-returning-nil))
406    
407    (defun find-class-cell (symbol &optional dont-create-p)
408    (or (gethash symbol *find-class*)    (or (gethash symbol *find-class*)
409          (unless dont-create-p
410            (unless (legal-class-name-p symbol)
411              (error "~S is not a legal class name." symbol))
412            (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
413    
414    (defvar *create-classes-from-internal-structure-definitions-p* t)
415    
416    (defun find-class-from-cell (symbol cell &optional (errorp t))
417      (or (find-class-cell-class cell)
418          (and *create-classes-from-internal-structure-definitions-p*
419               (structure-type-p symbol)
420               (find-structure-class symbol))
421        (cond ((null errorp) nil)        (cond ((null errorp) nil)
422              ((legal-class-name-p symbol)              ((legal-class-name-p symbol)
423               (error "No class named: ~S." symbol))               (error "No class named: ~S." symbol))
424              (t              (t
425               (error "~S is not a legal class name." symbol)))))               (error "~S is not a legal class name." symbol)))))
426    
427    (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
428      (unless (find-class-cell-class cell)
429        (find-class-from-cell symbol cell errorp))
430      (find-class-cell-predicate cell))
431    
432    (defun legal-class-name-p (x)
433      (and (symbolp x)
434           (not (keywordp x))))
435    
436    (defun find-class (symbol &optional (errorp t) environment)
437      (declare (ignore environment))
438      (find-class-from-cell symbol (find-class-cell symbol errorp) errorp))
439    
440    (defun find-class-predicate (symbol &optional (errorp t) environment)
441      (declare (ignore environment))
442      (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp))
443    
444    #-setf
445  (defsetf find-class (symbol &optional (errorp t) environment) (new-value)  (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
446    (declare (ignore errorp environment))    (declare (ignore errorp environment))
447    `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))    `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
448    
449  (defun SETF\ PCL\ FIND-CLASS (new-value symbol)  (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
450    (if (legal-class-name-p symbol)    (if (legal-class-name-p symbol)
451        (setf (gethash symbol *find-class*) new-value)        (setf (find-class-cell-class (find-class-cell symbol)) new-value)
452          (error "~S is not a legal class name." symbol)))
453    
454    #-setf
455    (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
456      (declare (ignore errorp environment))
457      `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
458    
459    (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
460              (new-value symbol)
461      (if (legal-class-name-p symbol)
462          (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
463        (error "~S is not a legal class name." symbol)))        (error "~S is not a legal class name." symbol)))
464    
465  (defun find-wrapper (symbol)  (defun find-wrapper (symbol)
# Line 435  Line 517 
517                       tail)                       tail)
518                   (setq tail (funcall ,by tail))))))                   (setq tail (funcall ,by tail))))))
519    
520    (defmacro function-funcall (form &rest args)
521      #-cmu `(funcall ,form ,@args)
522      #+cmu `(funcall (the function ,form) ,@args))
523    
524    (defmacro function-apply (form &rest args)
525      #-cmu `(apply ,form ,@args)
526      #+cmu `(apply (the function ,form) ,@args))
527    
528    
529    ;;;
530    ;;; Convert a function name to its standard setf function name.  We have to
531    ;;; do this hack because not all Common Lisps have yet converted to having
532    ;;; setf function specs.
533    ;;;
534    ;;; In a port that does have setf function specs you can use those just by
535    ;;; making the obvious simple changes to these functions.  The rest of PCL
536    ;;; believes that there are function names like (SETF <foo>), this is the
537    ;;; only place that knows about this hack.
538    ;;;
539    (eval-when (compile load eval)
540    ; In 15e (and also 16c), using the built in setf mechanism costs
541    ; a hash table lookup every time a setf function is called.
542    ; Uncomment the next line to use the built in setf mechanism.
543    ;#+cmu (pushnew :setf *features*)
544    )
545    
546    (eval-when (compile load eval)
547    
548    #-setf
549    (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
550    
551    (defun get-setf-function-name (name)
552      #+setf `(setf ,name)
553      #-setf
554      (or (gethash name *setf-function-names*)
555          (setf (gethash name *setf-function-names*)
556                (let ((pkg (symbol-package name)))
557                  (if pkg
558                      (intern (format nil
559                                      "SETF ~A ~A"
560                                      (package-name pkg)
561                                      (symbol-name name))
562                              *the-pcl-package*)
563                      (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
564    
565    ;;;
566    ;;; Call this to define a setf macro for a function with the same behavior as
567    ;;; specified by the SETF function cleanup proposal.  Specifically, this will
568    ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
569    ;;;
570    ;;; do-standard-defsetf                  A macro interface for use at top level
571    ;;;                                      in files.  Unfortunately, users may
572    ;;;                                      have to use this for a while.
573    ;;;
574    ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
575    ;;;
576    ;;; do-standard-defsetf-1                A functional interface called by the
577    ;;;                                      above, defmethod and defgeneric.
578    ;;;                                      Since this is all a crock anyways,
579    ;;;                                      users are free to call this as well.
580    ;;;
581    (defmacro do-standard-defsetf (&rest function-names)
582      `(eval-when (compile load eval)
583         (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
584    
585    (defun do-standard-defsetfs-for-defclass (accessors)
586      (dolist (name accessors) (do-standard-defsetf-1 name)))
587    
588    (defun do-standard-defsetf-1 (function-name)
589      #+setf
590      (declare (ignore function-name))
591      #+setf nil
592      #-setf
593      (unless (setfboundp function-name)
594        (let* ((setf-function-name (get-setf-function-name function-name)))
595    
596          #+Genera
597          (let ((fn #'(lambda (form)
598                        (lt::help-defsetf
599                          '(&rest accessor-args) '(new-value) function-name 'nil
600                          `(`(,',setf-function-name ,new-value .,accessor-args))
601                          form))))
602            (setf (get function-name 'lt::setf-method) fn
603                  (get function-name 'lt::setf-method-internal) fn))
604    
605          #+Lucid
606          (lucid::set-simple-setf-method
607            function-name
608            #'(lambda (form new-value)
609                (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
610                                         (cdr form)))
611                       (vars (mapcar #'car bindings)))
612                  ;; This may wrap spurious LET bindings around some form,
613                  ;;   but the PQC compiler will unwrap then.
614                  `(LET (,.bindings)
615                     (,setf-function-name ,new-value . ,vars)))))
616    
617          #+kcl
618          (let ((helper (gensym)))
619            (setf (macro-function helper)
620                  #'(lambda (form env)
621                      (declare (ignore env))
622                      (let* ((loc-args (butlast (cdr form)))
623                             (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
624                             (vars (mapcar #'car bindings)))
625                        `(let ,bindings
626                           (,setf-function-name ,(car (last form)) ,@vars)))))
627            (eval `(defsetf ,function-name ,helper)))
628          #+Xerox
629          (flet ((setf-expander (body env)
630                   (declare (ignore env))
631                   (let ((temps
632                           (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
633                                   (cdr body)))
634                         (forms (cdr body))
635                         (vars (list (gensym))))
636                     (values temps
637                             forms
638                             vars
639                             `(,setf-function-name ,@vars ,@temps)
640                             `(,function-name ,@temps)))))
641            (let ((setf-method-expander (intern (concatenate 'string
642                                                             (symbol-name function-name)
643                                                             "-setf-expander")
644                                         (symbol-package function-name))))
645              (setf (get function-name :setf-method-expander) setf-method-expander
646                    (symbol-function setf-method-expander) #'setf-expander)))
647    
648          #-(or Genera Lucid kcl Xerox)
649          (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
650                   (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
651                          (vars (mapcar #'car bindings)))
652                      `(let ,bindings
653                          (,',setf-function-name ,new-value ,@vars)))))
654    
655          )))
656    
657    (defun setfboundp (symbol)
658      #+Genera (not (null (get-properties (symbol-plist symbol)
659                                          'lt::(derived-setf-function trivial-setf-method
660                                                setf-equivalence setf-method))))
661      #+Lucid  (locally
662                 (declare (special lucid::*setf-inverse-table*
663                                   lucid::*simple-setf-method-table*
664                                   lucid::*setf-method-expander-table*))
665                 (or (gethash symbol lucid::*setf-inverse-table*)
666                     (gethash symbol lucid::*simple-setf-method-table*)
667                     (gethash symbol lucid::*setf-method-expander-table*)))
668      #+kcl    (or (get symbol 'si::setf-method)
669                   (get symbol 'si::setf-update-fn)
670                   (get symbol 'si::setf-lambda))
671      #+Xerox  (or (get symbol :setf-inverse)
672                   (get symbol 'il:setf-inverse)
673                   (get symbol 'il:setfn)
674                   (get symbol :shared-setf-inverse)
675                   (get symbol :setf-method-expander)
676                   (get symbol 'il:setf-method-expander))
677      #+:coral (or (get symbol 'ccl::setf-inverse)
678                   (get symbol 'ccl::setf-method-expander))
679      #+cmu (fboundp `(setf ,symbol))
680      #-(or Genera Lucid KCL Xerox :coral cmu) nil)
681    
682    );eval-when
683    
684    
685    ;;;
686    ;;; PCL, like user code, must endure the fact that we don't have a properly
687    ;;; working setf.  Many things work because they get mentioned by a defclass
688    ;;; or defmethod before they are used, but others have to be done by hand.
689    ;;;
690    (do-standard-defsetf
691      class-wrapper                                 ;***
692      generic-function-name
693      method-function-plist
694      method-function-get
695      plist-value
696      object-plist
697      gdefinition
698      slot-value-using-class
699      )
700    
701    (defsetf slot-value set-slot-value)
702    
703    (defvar *redefined-functions* nil)
704    
705    (defmacro original-definition (name)
706      `(get ,name ':definition-before-pcl))
707    
708    (defun redefine-function (name new)
709      (pushnew name *redefined-functions*)
710      (unless (original-definition name)
711        (setf (original-definition name)
712              (symbol-function name)))
713      (setf (symbol-function name)
714            (symbol-function new)))
715    
716    (defun reset-pcl-package () ; Try to do this safely
717      (let* ((vars '(*pcl-directory* *default-pathname-extensions* *pathname-extensions*))
718             (names (mapcar #'symbol-name vars))
719             (values (mapcar #'symbol-value vars)))
720        (when (boundp '*redefined-functions*)
721          (dolist (sym *redefined-functions*)
722            (setf (symbol-function sym) (original-definition sym)))
723          #||;; maybe even this isn't good enough
724          #+genera (scl:pkg-kill "PCL")
725          #+lucid (lcl:delete-package "PCL")
726          #-(or genera lucid) (rename-package "PCL" (symbol-name (gensym)))
727          (make-package "PCL" :use '("LISP"))
728          ||#
729          (let ((pkg (find-package "PCL")))
730            (do-symbols (sym pkg)
731              (when (eq pkg (symbol-package sym))
732                (unless (constantp sym)
733                  (makunbound sym))
734                (fmakunbound sym)
735                (setf (symbol-plist sym) nil))))
736          (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
737            (do-symbols (sym pkg)
738              (makunbound sym)
739              (fmakunbound sym)
740              (setf (symbol-plist sym) nil)))
741          (let ((pcl (find-package "PCL")))
742            (mapcar #'(lambda (name value)
743                        (let ((var (intern name pcl)))
744                          (proclaim `(special ,var))
745                          (set var value)))
746                    names values)))
747          nil))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5