From b9a934f729af34bd81b53e4bc0873078baf1a650 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sat, 19 Oct 1991 17:23:46 +0000 Subject: [PATCH] Merged with latest PCL version. --- pcl/boot.lisp | 245 +++++++++++++++----------- pcl/construct.lisp | 20 ++- pcl/defclass.lisp | 43 ++++- pcl/defs.lisp | 166 +++++++++-------- pcl/defsys.lisp | 79 +++++++-- pcl/env.lisp | 42 +---- pcl/fin.lisp | 431 +++++++++++++++++++++++++++++++++++++++++++-- pcl/lap.lisp | 1 + pcl/pkg.lisp | 1 + pcl/plap.lisp | 4 +- pcl/quadlap.lisp | 2 +- pcl/walk.lisp | 73 ++++++-- 12 files changed, 837 insertions(+), 270 deletions(-) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index df16e51e8..eb38a60a8 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -268,9 +268,8 @@ work during bootstrapping. ',name ',qualifiers (list ,@(mapcar #'(lambda (specializer) - (if (and (consp specializer) - (eq (car specializer) 'eql)) - ``(eql ,,(cadr specializer)) + (if (consp specializer) + ``(,',(car specializer) ,,(cadr specializer)) `',specializer)) specializers)) ',(specialized-lambda-list-lambda-list lambda-list) @@ -287,16 +286,32 @@ work during bootstrapping. (when (listp name) (do-standard-defsetf-1 (cadr name))) (multiple-value-bind (fn-form specializers doc plist) (expand-defmethod-internal name qualifiers lambda-list body env) - (declare (ignore doc plist)) (let ((fn-args (cadadr fn-form)) - (fn-body (cddadr fn-form))) - `(defun (method ,name ,@qualifiers ,specializers) ,fn-args - (declare ,@(when proto-method - `((pcl-method-class - ,(class-name (class-of proto-method))))) - (pcl-lambda-list - ,(specialized-lambda-list-lambda-list lambda-list))) - ,@fn-body)))) + (fn-body (cddadr fn-form)) + (method-name `(method ,name ,@qualifiers ,specializers))) + `(progn + (proclaim '(function ,name)) + (defun ,method-name ,fn-args + ,@fn-body) + (load-defmethod + ',(if proto-method + (class-name (class-of proto-method)) + 'standard-method) + ',name + ',qualifiers + (list ,@(mapcar #'(lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) ,,(cadr specializer)) + `',specializer)) + specializers)) + ',(specialized-lambda-list-lambda-list lambda-list) + ',doc + ',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by + ;passing the cache-symbol + ;here in addition to in the + ;plist. + ',plist + #',method-name))))) (defun expand-defmethod-internal (generic-function-name qualifiers specialized-lambda-list body env) @@ -348,6 +363,8 @@ work during bootstrapping. (call-next-method-p nil) ;flag indicating that call-next-method ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method (next-method-p-p nil) ;flag indicating that next-method-p ;should be in the method definition (save-original-args nil) ;flag indicating whether or not the @@ -380,7 +397,8 @@ work during bootstrapping. ((not (listp form)) form) ((eq (car form) 'call-next-method) (setq call-next-method-p 't) - (setq save-original-args (not (cdr form))) + (unless (cdr form) + (setq save-original-args t)) form) ((eq (car form) 'next-method-p) (setq next-method-p-p 't) @@ -389,13 +407,16 @@ work during bootstrapping. (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p 't) (setq save-original-args 't) + (setq closurep t) form) ((eq (cadr form) 'next-method-p) (setq next-method-p-p 't) + (setq closurep t) form) (t nil)))) ((and (or (eq (car form) 'slot-value) - (eq (car form) 'set-slot-value)) + (eq (car form) 'set-slot-value) + (eq (car form) 'slot-boundp)) (symbolp (cadr form)) (constantp (caddr form))) (let ((parameter @@ -406,7 +427,9 @@ work during bootstrapping. (slot-value (optimize-slot-value slots parameter form)) (set-slot-value - (optimize-set-slot-value slots parameter form)))))) + (optimize-set-slot-value slots parameter form)) + (slot-boundp + (optimize-slot-boundp slots parameter form)))))) (t form)))) (setq walked-lambda (walk-form method-lambda env #'walk-function)) @@ -476,16 +499,11 @@ work during bootstrapping. applyp aux-bindings call-next-method-p - next-method-p-p) + next-method-p-p + closurep) `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body)))) - #+Genera - (setq fn-body `(lambda ,(cadr fn-body) - (declare (pcl-documentation ,documentation) - (pcl-plist ,plist)) - ,@(cddr fn-body))) - (values `(function ,fn-body) specializers @@ -501,8 +519,46 @@ work during bootstrapping. applyp aux-bindings call-next-method-p - next-method-p-p) - (cond ((and (null save-original-args) + next-method-p-p + closurep) + (cond ((and (null closurep) + (null applyp) + (null save-original-args)) + ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and + ;; all args are mandatory (else APPLYP would be true). + `(lambda ,lambda-list + ,@walked-declarations + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (macrolet ((call-next-method ,lambda-list + '(if .next-method. + (let ((*next-methods* .next-methods.)) + (funcall .next-method. ,@lambda-list)) + (error "No next method."))) + (next-method-p () `(not (null .next-method.)))) + ,@walked-lambda-body)))) + ((and (null closurep) + (null applyp) + save-original-args) + ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the + ;; body with zero args, so we have to save the original args. + (if save-original-args + ;; CALL-NEXT-METHOD is sometimes called with no args + `(lambda ,original-args + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (macrolet ((call-next-method (&rest cnm-args) + `(if .next-method. + (let ((*next-methods* .next-methods.)) + (funcall .next-method. + ,@(if cnm-args cnm-args ',original-args))) + (error "No next method."))) + (next-method-p () `(not (null .next-method.)))) + (let* (,@(mapcar #'list lambda-list original-args) + ,@aux-bindings) + ,@walked-declarations + ,@walked-lambda-body)))))) + ((and (null save-original-args) (null applyp)) ;; ;; We don't have to save the original arguments. In addition, @@ -719,7 +775,7 @@ work during bootstrapping. :initable-instance-variables) #+Lispm -(zl:defmethod #+symbolics (dbg:report generic-clobbers-function) +(zl:defmethod #+Genera (dbg:report generic-clobbers-function) #+ti (generic-clobbers-function :report) (stream) (format stream @@ -727,7 +783,7 @@ work during bootstrapping. name (if (and (symbolp name) (macro-function name)) "macro" "function"))) -#+Symbolics +#+Genera (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) () "Make it specializable anyway?" (make-specializable name)) @@ -860,9 +916,7 @@ work during bootstrapping. (defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name) - ;; Hmm what is this use of when buying me?? - (when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers) - (setq specializers (parse-specializers specializers))) + (setq specializers (parse-specializers specializers)) (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers specializers @@ -1053,7 +1107,9 @@ work during bootstrapping. #'do-main-combined-method))) (apply (caar around) args)))))) -(defun fix-early-generic-functions (&optional noisyp) +(defvar *fegf-debug-p* nil) + +(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) (allocate-instance (find-class 'standard-generic-function));Be sure this ;class has an ;instance. @@ -1166,33 +1222,22 @@ work during bootstrapping. (defun parse-specializers (specializers) (flet ((parse (spec) - (cond ((symbolp spec) - (or (find-class spec nil) - (error - "~S used as a specializer,~%~ - but is not the name of a class." - spec))) - ((and (listp spec) - (eq (car spec) 'eql) - (null (cddr spec))) - (make-instance 'eql-specializer :object (cadr spec)) ;*EQL* -; spec - ) - (t (error "~S is not a legal specializer." spec))))) + (let ((result (specializer-from-type spec))) + (if (specializerp result) + result + (if (symbolp spec) + (error "~S used as a specializer,~%~ + but is not the name of a class." + spec) + (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) (defun unparse-specializers (specializers-or-method) (if (listp specializers-or-method) (flet ((unparse (spec) - (cond ((classp spec) - (or (class-name spec) spec)) - ((eql-specializer-p spec) ;*EQL* - (eql-specializer-object spec) -; (and (listp spec) (eq (car spec) 'eql)) -; spec - ) - (t - (error "~S is not a legal specializer." spec))))) + (if (specializerp spec) + (type-from-specializer spec) + (error "~S is not a legal specializer." spec)))) (mapcar #'unparse specializers-or-method)) (unparse-specializers (method-specializers specializers-or-method)))) @@ -1303,59 +1348,56 @@ work during bootstrapping. -(defmacro with-slots - (slots instance &body body &environment env) - (let ((gensym (gensym)) - (specs (mapcar #'(lambda (ss) - (if (consp ss) - (list (car ss) - (variable-lexical-p (car ss) env) - (cadr ss)) - (list ss (variable-lexical-p ss env) ss))) - slots))) - (expand-with-slots specs - body - env - gensym - instance - #'(lambda (s) `(slot-value ,gensym ',s))))) - -(defmacro with-accessors - (slot-accessor-pairs instance &body body &environment env) - (let ((gensym (gensym)) - (specs (mapcar #'(lambda (ss) - (list (car ss) - (variable-lexical-p (car ss) env) - (cadr ss))) - slot-accessor-pairs))) - (expand-with-slots specs - body - env - gensym - instance - #'(lambda (a) `(,a ,gensym))))) - -(defun expand-with-slots (specs body env gensym instance translate-fn) - `(let ((,gensym ,instance)) - ,@(and (symbolp instance) - `((declare (variable-rebinding ,gensym ,instance)))) - ,gensym - ,@(cdr (walk-form `(progn ,@body) - env - #'(lambda (f c e) - (expand-with-slots-internal specs - f - c - translate-fn - e)))))) - -(defun expand-with-slots-internal (specs form context translate-fn env) +(defmacro symbol-macrolet (bindings &body body &environment env) + (let ((specs (mapcar #'(lambda (binding) + (list (car binding) + (variable-lexical-p (car binding) env) + (cadr binding))) + bindings))) + (walk-form `(progn ,@body) + env + #'(lambda (f c e) + (expand-symbol-macrolet-internal specs f c e))))) + +(defmacro with-slots (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + ,@(and (symbolp instance) + `((declare (variable-rebinding ,in ,instance)) + (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (let ((variable-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,variable-name + (slot-value ,in ',slot-name)))) + slots) + ,@body)))))) + +(defmacro with-accessors (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + ,@(and (symbolp instance) + `((declare (variable-rebinding ,in ,instance)) + (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (let ((variable-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,variable-name + (,accessor-name ,in)))) + slots) + ,@body)))))) + +(defun expand-symbol-macrolet-internal (specs form context env) (let ((entry nil)) (cond ((not (eq context :eval)) form) ((symbolp form) (if (and (setq entry (assoc form specs)) (eq (cadr entry) (variable-lexical-p form env))) - (funcall translate-fn (caddr entry)) + (caddr entry) form)) ((not (listp form)) form) ((member (car form) '(setq setf)) @@ -1374,7 +1416,7 @@ work during bootstrapping. (variable-lexical-p (car tail) env))) (progn (setq kind 'setf) - (funcall translate-fn (caddr entry))) + (caddr entry)) (car tail)) (cadr tail) (scan-setf (cddr tail)))))) @@ -1392,3 +1434,4 @@ work during bootstrapping. gensyms))))) (t form)))) + diff --git a/pcl/construct.lisp b/pcl/construct.lisp index 8b4c84d63..ae63eda4d 100644 --- a/pcl/construct.lisp +++ b/pcl/construct.lisp @@ -580,9 +580,11 @@ (constants ())) (dolist (slotd (class-slots class)) (let ((name (slotd-name slotd)) - (initform (slotd-initform slotd))) + (initform (slotd-initform slotd)) + (initfn (slotd-initfunction slotd))) (cond ((null (memq name layout))) - ((eq initform *slotd-unsupplied*) + ((or (eq initform *slotd-unsupplied*) + (null initfn)) (push (cons name *slot-unbound*) constants)) ((constantp initform) (push (cons name (eval initform)) constants) @@ -815,7 +817,9 @@ (initfn (slotd-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) - (unless (eq form *slotd-unsupplied*) (bail-out))) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) ((member position used-positions)) ((or (constantp form) (eq form *slotd-unsupplied*))) @@ -960,7 +964,9 @@ (initfn (slotd-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) - (unless (eq form *slotd-unsupplied*) (bail-out))) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) ((member position used-positions)) ((or (constantp form) (eq form *slotd-unsupplied*))) @@ -1086,9 +1092,12 @@ (let* ((alloc (slotd-allocation slotd)) (name (slotd-name slotd)) (form (slotd-initform slotd)) + (initfn (slotd-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) - (unless (eq form *slotd-unsupplied*) (bail-out))) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) ((member position used-positions)) ((or (constantp form) (eq form *slotd-unsupplied*))) @@ -1096,3 +1105,4 @@ (bail-out))))) (values constants (nreverse supplied-initarg-positions))))) + diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index 9c417c068..1f534f0c9 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -45,16 +45,48 @@ (defun make-top-level-form (name times form) (flet ((definition-name () (if (and (listp name) - (memq (car name) '(class method method-combination))) + (memq (car name) '(defmethod defclass class method method-combination))) (format nil "~A~{ ~S~}" (capitalize-words (car name) ()) (cdr name)) (format nil "~S" name)))) (definition-name) #+Genera - (let ((thunk-name (make-symbol "TOP-LEVEL-FORM"))) - `(eval-when ,times - (defun ,thunk-name () (declare (sys:function-parent ,@name)) ,form) - (,thunk-name))) + (progn + #-Genera-Release-8 + (let ((thunk-name (gensym "TOP-LEVEL-FORM"))) + `(eval-when ,times + (defun ,thunk-name () + (declare (sys:function-parent + ,(cond ((listp name) + (case (first name) + (defmethod `(method ,@(rest name))) + (otherwise (second name)))) + (t name)) + ,(cond ((listp name) + (case (first name) + ((defmethod defgeneric) 'defun) + ((defclass) 'defclass) + (otherwise (first name)))) + (t 'defun)))) + ,form) + (,thunk-name))) + #+Genera-Release-8 + `(compiler-let ((compiler:default-warning-function ',name)) + (eval-when ,times + (funcall #'(lambda () + (declare ,(cond ((listp name) + (case (first name) + ((defclass) + `(sys:function-parent ,(second name) defclass)) + ((defmethod) + `(sys:function-name (method ,@(rest name)))) + ((defgeneric) + `(sys:function-name ,(second name))) + (otherwise + `(sys:function-name ,name)))) + (t + `(sys:function-name ,name)))) + ,form))))) #+LCL3.0 `(compiler-let ((lucid::*compiler-message-string* (or lucid::*compiler-message-string* @@ -269,3 +301,4 @@ (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) ecd)) + diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 0a39bf3b5..fa74bdb13 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -152,7 +152,9 @@ #-cmu (defun setfboundp (symbol) - #+Genera nil + #+Genera (not (null (get-properties (symbol-plist symbol) + 'lt::(derived-setf-function trivial-setf-method + setf-equivalence setf-method)))) #+Lucid (locally (declare (special lucid::*setf-inverse-table* lucid::*simple-setf-method-table* @@ -305,29 +307,87 @@ (name (fdefine-carefully (get-setf-function-name name) new-value)))) +(defun type-class (type) + (if (consp type) + (case (car type) + (class-eq (cadr type)) + (eql (class-of (cadr type))) + (t (and (null (cdr type)) (find-class (car type) nil)))) + (if (symbolp type) + (find-class type nil) + (and (class-specializer-p type) + (specializer-class type))))) + +(defun class-type-p (type) + (if (consp type) + (and (null (cdr type)) (find-class (car type) nil)) + (if (symbolp type) + (find-class type nil) + (and (classp type) type)))) +;;;;;; +(defun exact-class-type-p (type) + (if (consp type) + (or (eq (car type) 'class-eq) (eq (car type) 'eql)) + (exact-class-specializer-p type))) + +(defun make-class-eq-predicate (class) + (when (symbolp class) (setq class (find-class class))) + #'(lambda (object) (eq class (class-of object)))) + +(deftype class-eq (class) + `(satisfies ,(make-class-eq-predicate class))) + +(defun class-eq-type-p (type) + (if (consp type) + (eq (car type) 'class-eq) + (class-eq-specializer-p type))) +;;;;;; +(defun make-eql-predicate (eql-object) + #'(lambda (object) (eql eql-object object))) + +(deftype eql (type-object) + `(satisfies ,(make-eql-predicate type-object))) + +(defun eql-type-p (type) + (if (consp type) + (eq (car type) 'eql) + (eql-specializer-p type))) + +(defun type-object (type) + (if (consp type) + (cadr type) + (specializer-object type))) + +;;;;;; +(defun not-type-p (type) + (and (consp type) (eq (car type) 'not))) + +(defun not-type (type) + (cadr type)) + ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. ;;; (defun *typep (object type) - (if (classp type) - (let ((class (class-of object))) - (if class - (memq type (class-precedence-list class)) - nil)) - (let ((class (find-class type nil))) - (if class - (*typep object class) - (typep object type))))) + (let ((specializer (or (class-type-p type) + (and (specializerp type) type)))) + (cond (specializer + (specializer-type-p object specializer)) + ((not-type-p type) + (not (*typep object (not-type type)))) + (t + (typep object type))))) (defun *subtypep (type1 type2) - (let ((c1 (if (classp type1) type1 (find-class type1 nil))) - (c2 (if (classp type2) type2 (find-class type2 nil)))) - (if (and c1 c2) - (memq c2 (class-precedence-list c1)) - (if (or c1 c2) - nil ;This isn't quite right, but... - (subtypep type1 type2))))) + (let ((c1 (class-type-p type1)) + (c2 (class-type-p type2))) + (cond ((and c1 c2) + (values (memq c2 (class-precedence-list c1)) t)) + ((setq c1 (or c1 (specializerp type1))) + (specializer-applicable-using-type-p c1 type2)) + ((or (null c2) (classp c2)) + (subtypep type1 (if c2 (class-name c2) type2)))))) (defun do-satisfies-deftype (name predicate) #| @@ -377,8 +437,13 @@ *the-class-method* *the-class-generic-function* *the-class-standard-class* + *the-class-funcallable-standard-class* *the-class-standard-method* - *the-class-standard-generic-function*)) + *the-class-standard-generic-function* + *the-class-standard-effective-slot-definition* + + *the-eslotd-standard-class-slots* + *the-eslotd-funcallable-standard-class-slots*)) (proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* @@ -518,6 +583,8 @@ (defclass specializer (metaobject) ()) +(defclass class-specializer (specializer) ()) + (defclass definition-source-mixin (standard-object) ((source :initform (load-truename) @@ -540,7 +607,7 @@ ;;; have the class CLASS in its class precedence list. ;;; (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin - specializer) + class-specializer) ((name :initform nil :initarg :name @@ -629,7 +696,13 @@ :accessor slotd-type) (documentation :initform "" - :initarg :documentation))) + :initarg :documentation) + (class + :initform nil + :accessor slotd-class) + (instance-index + :initform nil + :accessor slotd-instance-index))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) @@ -646,7 +719,7 @@ (defclass eql-specializer (specializer) - ((object :initarg :object :reader eql-specializer-object))) + ((object :initarg :object :reader specializer-object))) @@ -663,53 +736,4 @@ ,@body) (,improper-list-handler))))) -(defun legal-std-documentation-p (x) - (if (or (null x) (stringp x)) - t - "a string or NULL")) - -(defun legal-std-lambda-list-p (x) - (declare (ignore x)) - t) - -(defun legal-std-method-function-p (x) - (if (functionp x) - t - "a function")) - -(defun legal-std-qualifiers-p (x) - (flet ((improper-list () - (return-from legal-std-qualifiers-p "Is not a proper list."))) - (dolist-carefully (q x improper-list) - (let ((ok (legal-std-qualifier-p q))) - (unless (eq ok t) - (return-from legal-std-qualifiers-p - (format nil "Contains ~S which ~A" q ok))))) - t)) - -(defun legal-std-qualifier-p (x) - (if (and x (atom x)) - t - "is not a non-null atom")) - -(defun legal-std-slot-name-p (x) - (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") - ((keywordp x) "is a keyword and so cannot be bound") - ((memq x '(t nil)) "cannot be bound") - (t t))) - -(defun legal-std-specializers-p (x) - (flet ((improper-list () - (return-from legal-std-specializers-p "Is not a proper list."))) - (dolist-carefully (s x improper-list) - (let ((ok (legal-std-specializer-p s))) - (unless (eq ok t) - (return-from legal-std-specializers-p - (format nil "Contains ~S which ~A" s ok))))) - t)) - -(defun legal-std-specializer-p (x) - (if (or (classp x) - (eql-specializer-p x)) - t - "is neither a class object nor an eql specializer")) + diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index e3ccaa9d4..eb1e020f3 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -70,32 +70,40 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "5/1/90 May Day PCL (REV 2)") +(defvar *pcl-system-date* "5/1/90 May Day PCL (REV 4b)") ;;; ;;; Various hacks to get people's *features* into better shape. ;;; (eval-when (compile load eval) - #+(and Symbolics Lispm) (multiple-value-bind (major minor) (sct:get-release-version) + (etypecase minor + (integer) + (string (setf minor (parse-integer minor :junk-allowed t)))) (pushnew :genera *features*) (ecase major ((6) (pushnew :genera-release-6 *features*)) ((7) (pushnew :genera-release-7 *features*) - (ecase (etypecase minor - (integer minor) - (string (digit-char-p (char minor 0)))) + (ecase minor ((0 1) (pushnew :genera-release-7-1 *features*)) ((2) (pushnew :genera-release-7-2 *features*)) ((3) (pushnew :genera-release-7-3 *features*)) - ((4) (pushnew :genera-release-7-4 *features*)) - ((5) (pushnew :genera-release-7-5 *features*)))))) - + ((4) (pushnew :genera-release-7-4 *features*)))) + ((8) + (pushnew :genera-release-8 *features*) + (ecase minor + ((0) (pushnew :genera-release-8-0 *features*)) + ((1) (pushnew :genera-release-8-1 *features*)))))) + #+CLOE-Runtime + (let ((version (lisp-implementation-version))) + (when (string-equal version "2.0" :end1 (min 3 (length version))) + (pushnew :cloe-release-2 *features*))) + (dolist (feature *features*) (when (and (symbolp feature) ;3600!! (equal (symbol-name feature) "CMU")) @@ -118,7 +126,7 @@ #+(and HP Lucid) (push :HP-Lucid *features*) - #+(and HP (not Lucid)) + #+(and HP (not Lucid) (not excl)) (push :HP-HPLabs *features*) #+Xerox @@ -208,7 +216,9 @@ and load your system with: #+Genera-Release-7-2 Rel-7-2 #+Genera-Release-7-3 Rel-7-2 ;OK for now #+Genera-Release-7-4 Rel-7-2 ;OK for now + #+Genera-Release-8 Rel-8 #+imach Ivory + #+Cloe-Runtime Cloe #+Lucid Lucid #+Xerox Xerox #+Xerox-Lyric Xerox-Lyric @@ -218,6 +228,7 @@ and load your system with: #+KCL KCL #+IBCL IBCL #+excl excl + #+(and excl sun4) excl-sun4 #+:CMU CMU #+HP-HPLabs HP-HPLabs #+:gclisp gclisp @@ -255,6 +266,7 @@ and load your system with: (car '(#+(and Genera (not imach)) ("lisp" . "bin") #+(and Genera imach) ("lisp" . "ibin") + #+Cloe-Runtime ("l" . "fasl") #+(and dec common vax (not ultrix)) ("LSP" . "FAS") #+(and dec common vax ultrix) ("lsp" . "fas") #+KCL ("lsp" . "o") @@ -268,6 +280,7 @@ and load your system with: #+(and Lucid IBM-RT-PC) ("lisp" . "bbin") #+(and Lucid MIPS) ("lisp" . "mbin") #+(and Lucid PRISM) ("lisp" . "abin") + #+(and Lucid PA) ("lisp" . "hbin") #+excl ("cl" . "fasl") #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*)) #+HP ("l" . "b") @@ -556,13 +569,31 @@ and load your system with: ;; compatibility. In 2.1 it was in the SYSTEM package, and i ;; 3.0 it's in the LUCID-COMMON-LISP package. ;; - #+LUCID (or lucid::*source-pathname* (bad-time)))) + #+LUCID (or lucid::*source-pathname* (bad-time)) + #-(or Lispm excl Xerox (and dec vax common) LUCID) nil)) (defvar *pcl-directory* (pathname "pcl:")) +#+Genera +(defvar *pcl-directory* + (let ((source (load-truename t))) + (flet ((subdir (name) + (scl:send source :new-pathname :raw-directory + (append (scl:send source :raw-directory) + (list name))))) + (cons source + #+genera-release-7-2 (subdir "rel-7-2") + #+genera-release-7-3 (subdir "rel-7-3") + #+genera-release-7-4 (subdir "rel-7-4") + #+genera-release-8-0 (subdir "rel-8-0") + #+genera-release-8-1 (subdir "rel-8-1") + )))) + +#+Cloe-Runtime +(defvar *pcl-directory* (pathname "/usr3/hornig/pcl/")) (defsystem pcl - *pcl-directory* + *pcl-directory* ;; ;; file load compile files which port ;; environment environment force the of @@ -573,6 +604,7 @@ and load your system with: ; (rel-6-patches t t () rel-6) ; (rel-7-1-patches t t () rel-7-1) (rel-7-2-patches t t () rel-7-2) + (rel-8-patches t t () rel-8) (ti-patches t t () ti) (pyr-patches t t () pyramid) (xerox-patches t t () xerox) @@ -588,6 +620,7 @@ and load your system with: (genera-low (low) (low) (low) Genera) + (cloe-low (low) (low) (low) Cloe) (lucid-low (low) (low) (low) Lucid) (Xerox-low (low) (low) (low) Xerox) (ti-low (low) (low) (low) TI) @@ -607,8 +640,8 @@ and load your system with: (fngen t t (low)) (lap t t (low)) (plap t t (low)) - (cpatch t t (low) excl) ;*** - (quadlap t t (low) excl) ;*** + (cpatch t t (low) excl-sun4) + (quadlap t t (low) excl-sun4) (cache t t (low defs)) (dlap t t (defs low fin cache lap)) (boot t t (defs fin)) @@ -637,6 +670,7 @@ and load your system with: (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) #+Lucid (lcl:*redefinition-action* nil) #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) ) (cond ((null m) (operate-on-system 'pcl :compile)) ((eq m :print) (operate-on-system 'pcl :compile () t)) @@ -650,12 +684,30 @@ and load your system with: (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) #+Lucid (lcl:*redefinition-action* nil) #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) ) (cond ((null m) (operate-on-system 'pcl :load)) ((eq m :query) (operate-on-system 'pcl :query-load))) (pushnew :pcl *features*) (pushnew :portable-commonloops *features*))) +#+Genera +;;; Make sure Genera bug mail contains the PCL bug data. A little +;;; kludgy, but what the heck. If they didn't mean for people to do +;;; this, they wouldn't have made private patch notes be flavored +;;; objects, right? Right. +(progn + (scl:defflavor pcl-private-patch-info ((description)) ()) + (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) () + (or description + (setf description (string-append "PCL version: " *pcl-system-date*)))) + (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) () + *pcl-directory*) + (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info)) + sct::*private-patch-info*) + (push (scl:make-instance 'pcl-private-patch-info) + sct::*private-patch-info*))) + (defun bug-report-info (&optional (stream *standard-output*)) (format stream "~&PCL system date: ~A~ ~&Lisp Implementation type: ~A~ @@ -747,3 +799,4 @@ and load your system with: (zwei:make-buffer-current original-buffer)))) + diff --git a/pcl/env.lisp b/pcl/env.lisp index 861d72c25..01f7159dd 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -29,45 +29,6 @@ (in-package 'pcl) -#+Genera -(progn - -(defvar *old-arglist*) - -(defun pcl-arglist (function &rest other-args) - (let ((defn nil)) - (cond ((and (fsc-instance-p function) - (generic-function-p function)) - (generic-function-pretty-arglist function)) - ((and (sys:validate-function-spec function) - (sys:fdefinedp function) - (setq defn (sys:fdefinition function)) - (fsc-instance-p defn) - (generic-function-p defn)) - (generic-function-pretty-arglist defn)) - (t (apply *old-arglist* function other-args))))) - -(eval-when (eval load) - (unless (boundp '*old-arglist*) - (setq *old-arglist* (symbol-function 'zl:arglist)) - (setf (symbol-function 'zl:arglist) #'pcl-arglist))) - - -(defvar *old-function-name*) - -(defun pcl-function-name (function &rest other-args) - (if (and (fsc-instance-p function) - (generic-function-p function)) - (generic-function-name function) - (apply *old-function-name* function other-args))) - -(eval-when (eval load) - (unless (boundp '*old-function-name*) - (setq *old-function-name* (symbol-function 'si:function-name)) - (setf (symbol-function 'si:function-name) #'pcl-function-name))) - -) - #+Lucid (progn @@ -100,6 +61,8 @@ (defgeneric describe-object (object stream)) +#-Genera (progn + #-cmu (defvar *old-describe* ()) @@ -317,3 +280,4 @@ (remove-method gf method) method))) +); #-genera progn diff --git a/pcl/fin.lisp b/pcl/fin.lisp index b3060d4ec..28d32b2b3 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -305,7 +305,7 @@ explicitly marked saying who wrote it. ;;; 3650), at least one nasty bug is fixed, and so far at least I've not ;;; seen any problems at all with this code. - mike thome (mthome@bbn.com) ;;; -#+Genera +#+(and Genera (not Genera-Release-8)) (progn (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) @@ -358,7 +358,9 @@ explicitly marked saying who wrote it. (make-trampoline new-value))))) (defun make-trampoline (function) + (declare (optimize (speed 3) (safety 0))) #'(lambda (&rest args) + #+Genera (declare (dbg:invisible-frame :pcl-internals)) (apply function args))) (defmacro funcallable-instance-data-1 (fin data) @@ -373,30 +375,321 @@ explicitly marked saying who wrote it. ;;; ;;; Make funcallable instances print out properly. ;;; -(defvar *old-print-lexical-closure*) - (defvar *print-lexical-closure* nil) (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0)) (declare (ignore depth)) + (declare (special *boot-state*)) (if (or (eq *print-lexical-closure* exp) (neq *boot-state* 'complete) (eq (class-of exp) *the-class-t*)) (let ((*print-lexical-closure* nil)) - (funcall *old-print-lexical-closure* exp stream slashify-p)) + (funcall (get 'si:print-lexical-closure ':definition-before-pcl) + exp stream slashify-p)) (let ((*print-escape* slashify-p) (*print-lexical-closure* exp)) (print-object exp stream)))) (eval-when (load eval) - (unless (boundp '*old-print-lexical-closure*) - (setq *old-print-lexical-closure* #'si:print-lexical-closure) - (setf (symbol-function 'si:print-lexical-closure) - 'pcl-print-lexical-closure))) + (unless (boundp '*boot-state*) + (setq *boot-state* nil)) + (unless (get 'si:print-lexical-closure ':definition-before-pcl) + (setf (get 'si:print-lexical-closure ':definition-before-pcl) + (symbol-function 'si:print-lexical-closure))) + (setf (symbol-function 'si:print-lexical-closure) + (symbol-function 'pcl-print-lexical-closure))) + +(defvar *function-name-level* 0) + +(defun pcl-function-name (function &rest other-args) + (if (and (eq *boot-state* 'complete) + (funcallable-instance-p function) + (generic-function-p function) + (<= *function-name-level* 2)) + (let ((*function-name-level* (1+ *function-name-level*))) + (generic-function-name function)) + (apply (get 'si:function-name ':definition-before-pcl) function other-args))) + +(eval-when (eval load) + (unless (get 'si:function-name ':definition-before-pcl) + (setf (get 'si:function-name ':definition-before-pcl) + (symbol-function 'si:function-name))) + (setf (symbol-function 'si:function-name) + (symbol-function 'pcl-function-name))) + +(defun pcl-arglist (function &rest other-args) + (let ((defn nil)) + (cond ((and (funcallable-instance-p function) + (generic-function-p function)) + (generic-function-pretty-arglist function)) + ((and (sys:validate-function-spec function) + (sys:fdefinedp function) + (setq defn (sys:fdefinition function)) + (funcallable-instance-p defn) + (generic-function-p defn)) + (generic-function-pretty-arglist defn)) + (t (apply (get 'zl:arglist ':definition-before-pcl) function other-args))))) + +(eval-when (eval load) + (unless (get 'zl:arglist ':definition-before-pcl) + (setf (get 'zl:arglist ':definition-before-pcl) + (symbol-function 'zl:arglist))) + (setf (symbol-function 'zl:arglist) + (symbol-function 'pcl-arglist))) + +;;; +;;; This code is adapted from frame-lexical-environment and frame-function. +;;; +#|| +dbg: +(progn + +(defvar *old-frame-function*) + +(defvar *inside-new-frame-function* nil) + +(defun new-frame-function (frame) + (let* ((fn (funcall *old-frame-function* frame)) + (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0)) + (env? #+3600 (location-contents location) + #+imach (%memory-read location :cycle-type %memory-scavenge))) + (or (when (cl:consp env?) + (let ((l2 (last2 env?))) + (when (eq (car l2) '.this-is-a-dfun.) + (cadr l2)))) + fn))) + +(defun pcl::doctor-dfun-for-the-debugger (gf dfun) + (when (sys:lexical-closure-p dfun) + (let* ((env (si:lexical-closure-environment dfun)) + (l2 (last2 env))) + (unless (eq (car l2) '.this-is-a-dfun.) + (setf (si:lexical-closure-environment dfun) + (nconc env (list '.this-is-a-dfun. gf)))))) + dfun) + +(defun last2 (l) + (labels ((scan (2ago tail) + (if (null tail) + 2ago + (if (cl:consp tail) + (scan (cdr 2ago) (cdr tail)) + nil)))) + (and (cl:consp l) + (cl:consp (cdr l)) + (scan l (cddr l))))) + +(eval-when (load) + (unless (boundp '*old-frame-function*) + (setq *old-frame-function* #'frame-function) + (setf (cl:symbol-function 'frame-function) 'new-frame-function))) + +) +||# );end of #+Genera + + +;;; +;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this. +;;; This minimizes the subprimitive mucking around. +;;; +#+(and Genera Genera-Release-8) +(progn + +(clos-internals::ensure-class + 'pcl-funcallable-instance + :direct-superclasses '(clos-internals:funcallable-instance) + :slots `((:name function + :initform #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function)) + :initfunction ,#'(lambda nil + #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function)))) + ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data)) + :metaclass 'clos:funcallable-standard-class) + +(defun pcl-funcallable-instance-trampoline (extra-arg &rest args) + (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg) + 3) + args)) + +(defun allocate-funcallable-instance-1 () + (let ((fin (clos:make-instance 'pcl-funcallable-instance))) + (setf (clos-internals::%funcallable-instance-function fin) + #'pcl-funcallable-instance-trampoline) + (setf (clos-internals::%funcallable-instance-extra-argument fin) + (sys:%make-pointer sys:dtp-instance + (clos-internals::%funcallable-instance-extra-argument fin))) + (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin) + fin)) + +(scl:defsubst funcallable-instance-p (x) + (and (sys:funcallable-instance-p x) + (eq (clos-internals::%funcallable-instance-function x) + #'pcl-funcallable-instance-trampoline))) + +(defun set-funcallable-instance-function (fin new-value) + (setf (clos:slot-value fin 'function) new-value)) + +(defmacro funcallable-instance-data-1 (fin data) + `(clos-internals:%funcallable-instance-ref + ,fin (+ 4 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (clos-internals:%funcallable-instance-ref + ,fin (+ 4 (funcallable-instance-data-position ,data))) + ,new-value)) + +(clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream) + (print-object fin stream)) + +(clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance)) + nil) + +(clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance)) + (declare (special *boot-state*)) + (if (and (eq *boot-state* 'complete) + (generic-function-p fin)) + (generic-function-name fin) + fin)) + +(clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance)) + (declare (special *boot-state*)) + (if (and (eq *boot-state* 'complete) + (generic-function-p fin)) + (generic-function-pretty-arglist fin) + '(&rest args))) + +);end of #+Genera + + + +#+Cloe-Runtime +(progn + +(defconstant funcallable-instance-closure-slots 5) +(defconstant funcallable-instance-closure-size + (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1)) + +#-CLOE-Release-2 (progn + +(defun allocate-funcallable-instance-1 () + (let ((data (system::make-funcallable-structure 'funcallable-instance + funcallable-instance-closure-size))) + (setf (system::%trampoline-ref data funcallable-instance-closure-slots) + 'funcallable-instance) + (set-funcallable-instance-function + data + #'(lambda (&rest ignore-them-too) + (declare (ignore ignore-them-too)) + (called-fin-without-function))) + data)) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (typep x 'system::trampoline) + (= (system::%trampoline-data-length x) funcallable-instance-closure-size) + (eq (system::%trampoline-ref x funcallable-instance-closure-slots) + 'funcallable-instance))) + +(defun set-funcallable-instance-function (fin new-value) + (when (not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + (etypecase new-value + (system::trampoline + (let ((length (system::%trampoline-data-length new-value))) + (cond ((> length funcallable-instance-closure-slots) + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))) + (t + (setf (system::%trampoline-function fin) + (system::%trampoline-function new-value)) + (dotimes (i length) + (setf (system::%trampoline-ref fin i) + (system::%trampoline-ref new-value i))))))) + (compiled-function + (setf (system::%trampoline-function fin) new-value)) + (function + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))))) + +(defmacro funcallable-instance-data-1 (fin data) + `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data))) + ,new-value)) + +) + +#+CLOE-Release-2 (progn + +(defun allocate-funcallable-instance-1 () + (let ((data (si::cons-closure funcallable-instance-closure-size))) + (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance) + (set-funcallable-instance-function + data + #'(lambda (&rest ignore-them-too) + (declare (ignore ignore-them-too)) + (error "Called a FIN without first setting its function."))) + data)) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (si::closurep x) + (= (si::closure-length x) funcallable-instance-closure-size) + (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance))) + +(defun set-funcallable-instance-function (fin new-value) + (when (not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + (etypecase new-value + (si::closure + (let ((length (si::closure-length new-value))) + (cond ((> length funcallable-instance-closure-slots) + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))) + (t + (setf (si::closure-function fin) (si::closure-function new-value)) + (dotimes (i length) + (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3)))))))) + (compiled-function + (setf (si::closure-function fin) new-value)) + (function + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))))) + +(defmacro funcallable-instance-data-1 (fin data) + `(si::closure-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data))) + ,new-value)) + +) + +) ;;; @@ -1119,7 +1412,7 @@ explicitly marked saying who wrote it. ;;; this file. ;;; -#+(or KCL IBCL) +#+(and KCL (not IBCL)) (progn (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) @@ -1225,6 +1518,111 @@ make_turbo_trampoline_internal(base0) (defentry make-trampoline (object) (object make_trampoline)) ) +#+IBCL +(progn ; From Rainy Day PCL. + +(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) + +(defconstant funcallable-instance-closure-size 15) + +(defun allocate-funcallable-instance-1 () + (let ((fin (allocate-funcallable-instance-2)) + (env + (make-list funcallable-instance-closure-size :initial-element nil))) + (set-cclosure-env fin env) + #+:turbo-closure (si:turbo-closure fin) + (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) + (setf (car env) *funcallable-instance-marker*) + fin)) + +(defun allocate-funcallable-instance-2 () + (let ((what-a-dumb-closure-variable ())) + #'(lambda (&rest args) + (declare (ignore args)) + (called-fin-without-function) + (setq what-a-dumb-closure-variable + (dummy-function what-a-dumb-closure-variable))))) + +(defun funcallable-instance-p (x) + (and (cclosurep x) + (let ((env (cclosure-env x))) + (when (listp env) + (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) + (eq (car env) *funcallable-instance-marker*))))) + +(defun set-funcallable-instance-function (fin new-value) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((cclosurep new-value) + (let* ((fin-env (cclosure-env fin)) + (new-env (cclosure-env new-value)) + (new-env-size (length new-env)) + (fin-env-size (- funcallable-instance-closure-size + (length funcallable-instance-data) + 1))) + (cond ((<= new-env-size fin-env-size) + (do ((i 0 (+ i 1)) + (new-env-tail new-env (cdr new-env-tail)) + (fin-env-tail fin-env (cdr fin-env-tail))) + ((= i fin-env-size)) + (setf (car fin-env-tail) + (if (< i new-env-size) + (car new-env-tail) + nil))) + (set-cclosure-self fin (cclosure-self new-value)) + (set-cclosure-data fin (cclosure-data new-value)) + (set-cclosure-start fin (cclosure-start new-value)) + (set-cclosure-size fin (cclosure-size new-value))) + (t + (set-funcallable-instance-function + fin + (make-trampoline new-value)))))) + ((typep new-value 'compiled-function) + ;; Write NILs into the part of the cclosure environment that is + ;; not being used to store the funcallable-instance-data. Then + ;; copy over the parts of the compiled function that need to be + ;; copied over. + (let ((env (cclosure-env fin))) + (dotimes (i (- funcallable-instance-closure-size + (length funcallable-instance-data) + 1)) + (setf (car env) nil) + (pop env))) + (set-cclosure-self fin (cfun-self new-value)) + (set-cclosure-data fin (cfun-data new-value)) + (set-cclosure-start fin (cfun-start new-value)) + (set-cclosure-size fin (cfun-size new-value))) + (t + (set-funcallable-instance-function fin + (make-trampoline new-value)))) + fin) + + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + +;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1 +;; and the defsetf +(defmacro funcallable-instance-data-1 (fin data &environment env) + ;; The compiler won't expand macros before deciding on optimizations, + ;; so we must do it here. + (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) + env)) + (index-form (if (constantp pos-form) + (- funcallable-instance-closure-size + (eval pos-form) + 2) + `(- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2)))) + #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin)) + #-:turbo-closure `(nth ,index-form (cclosure-env ,fin)))) + +) + ;;; ;;; In H.P. Common Lisp @@ -1515,18 +1913,20 @@ make_turbo_trampoline_internal(base0) (called-fin-without-function)) ccl::initial-fin-slots)) -;;; Make uvector-based objects (like funcallable instances) print better. #+:ccl-1.3 +(eval-when (eval compile load) + +;;; Make uvector-based objects (like funcallable instances) print better. (defun print-uvector-object (obj stream &optional print-level) (declare (ignore print-level)) (print-object obj stream)) ;;; Inform the print system about funcallable instance uvectors. -#+:ccl-1.3 -(eval-when (eval compile load) - (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object) - ccl:*write-uvector-alist* - :test #'equal)) +(pushnew (cons 'ccl::funcallable-instance #'print-uvector-object) + ccl:*write-uvector-alist* + :test #'equal) + +) (defun funcallable-instance-p (x) (and (eq (ccl::%type-of x) 'ccl::internal-structure) @@ -1576,3 +1976,4 @@ make_turbo_trampoline_internal(base0) (setf (fsc-instance-wrapper fin) wrapper (fsc-instance-slots fin) slots) fin)) + diff --git a/pcl/lap.lisp b/pcl/lap.lisp index 4972d33a6..9877a96f7 100644 --- a/pcl/lap.lisp +++ b/pcl/lap.lisp @@ -479,3 +479,4 @@ (error "LAP TEST 5 failed.")))) |# + diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 8593c4979..57c35a76b 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -180,3 +180,4 @@ ; ; ; )) + diff --git a/pcl/plap.lisp b/pcl/plap.lisp index 6e40319e8..0cf0a33c8 100644 --- a/pcl/plap.lisp +++ b/pcl/plap.lisp @@ -110,7 +110,8 @@ ,(lap-reg-initial-value-form reg))) (append i-regs v-regs t-regs)) (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) - (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))) + (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) + (optimize . ,*lap-optimize-declaration*)) ,.code))) (defconstant *empty-vector* '#()) @@ -310,3 +311,4 @@ (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) mask)) + diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp index ff1b9b319..0b6fba974 100644 --- a/pcl/quadlap.lisp +++ b/pcl/quadlap.lisp @@ -1,6 +1,6 @@ ;; -[Thu Mar 1 10:54:27 1990 by jkf]- ;; pcl to quad translation -;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.1.1.1 1991/10/19 16:45:45 ram Exp $ +;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.2 1991/10/19 17:23:26 ram Exp $ ;; ;; copyright (c) 1990 Franz Inc. ;; diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 1003ea606..c63c46254 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -475,6 +475,32 @@ );#+Genera +#+Cloe-Runtime +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + functions + (dolist (m macros) + (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) + env) + +(defun environment-function (env fn) + nil) + +(defun environment-macro (env macro) + (let ((entry (getf env macro))) + (if (and (consp entry) + (eq (car entry) 'compiler::macro)) + (values (cdr entry) t) + (values nil nil)))) + +);#+Cloe-Runtime + ;;; ;;; In Xerox Lisp, the compiler and interpreter use different structures for @@ -986,12 +1012,13 @@ ;;; Common Lisp nit: ;;; variable-globally-special-p should be defined in Common Lisp. ;;; -#-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs +#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs GCLisp TI pyramid) (defvar *globally-special-variables* ()) (defun variable-globally-special-p (symbol) #+Genera (si:special-variable-p symbol) + #+Cloe-Runtime (compiler::specialp symbol) #+Lucid (lucid::proclaimed-special-p symbol) #+TI (get symbol 'special) #+Xerox (il:variable-globally-special-p symbol) @@ -1007,7 +1034,7 @@ (get symbol 'clc::globally-special-in-compiler)) #+:CORAL (ccl::proclaimed-special-p symbol) - #-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs + #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs GCLisp TI pyramid :CORAL) (or (not (null (member symbol *globally-special-variables* :test #'eq))) (when (eval `(flet ((ref () ,symbol)) @@ -1534,23 +1561,30 @@ (defun walk-prog/prog* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) - (let* ((let/let* (car form)) - (bindings (cadr form)) - (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (walk-tagbody-1 real-body context real-env)) - new-env))) - (relist* - form let/let* walked-bindings walked-body)))) + (let* ((possible-block-name (second form)) + (blocked-prog (and (symbolp possible-block-name) + (not (eq possible-block-name 'nil))))) + (multiple-value-bind (let/let* block-name bindings body) + (if blocked-prog + (values (car form) (cadr form) (caddr form) (cdddr form)) + (values (car form) nil (cadr form) (cddr form))) + (let* ((walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations + body + #'(lambda (real-body real-env) + (walk-tagbody-1 real-body context real-env)) + new-env))) + (if block-name + (relist* + form let/let* block-name walked-bindings walked-body) + (relist* + form let/let* walked-bindings walked-body))))))) (defun walk-do/do* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) @@ -2042,3 +2076,4 @@ |# () + -- GitLab