From 0e259575bf20ccab281d8a9b436284b50133537c Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 27 Nov 1990 16:51:02 +0000 Subject: [PATCH] Added a source-transform for STD-INSTANCE-P that knows there are no subtypes. Added GENERIC-FUNCTION-TYPE-FROM-LAMBDA-LIST which figures out a function type that we can use in a type declaration to tell the compiler that a method has been defined & what its syntax is. --- pcl/cmu-low.lisp | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp index 959a5adf6..22d391bc5 100644 --- a/pcl/cmu-low.lisp +++ b/pcl/cmu-low.lisp @@ -35,6 +35,13 @@ (defun printing-random-thing-internal (thing stream) (format stream "{~X}" (sys:%primitive c:make-fixnum thing))) + +(eval-when (compile load eval) + (c:def-source-transform std-instance-p (x) + (ext:once-only ((n-x x)) + `(and (ext:structurep ,n-x) + (eq (kernel:structure-ref ,n-x 0) 'std-instance))))) + ;; ;;;;;; Cache No's ;; @@ -79,3 +86,42 @@ (system:%primitive c::set-function-name header new-name)) fcn))) +(in-package "C") + + +(defun keyword-spec-name (x) + (if (atom x) + (intern (symbol-name x) (find-package "KEYWORD")) + (let ((cx (car x))) + (if (atom cx) + (intern (symbol-name cx) (find-package "KEYWORD")) + (car cx))))) + + +(defun generic-function-type-from-lambda-list (name ll) + (multiple-value-bind (req opt restp ignore keyp keys allowp) + (parse-lambda-list ll) + (declare (ignore ignore)) + (let* ((old (info function type name)) + (old-ftype (if (function-type-p old) old nil)) + (old-keys (and old-ftype + (mapcar #'key-info-name + (function-type-keywords old-ftype))))) + `(function (,@(make-list (length req) :initial-element t) + ,@(when opt + `(&optional ,@(make-list (length opt) + :initial-element t))) + ,@(when (or (and old-ftype (function-type-rest old-ftype)) + restp) + '(&rest t)) + ,@(when (or (and old-ftype (function-type-keyp old-ftype)) + keyp) + '(&key)) + ,@(when (or (and old-ftype (function-type-allowp old-ftype)) + allowp) + '(&allow-other-keys)) + ,@(mapcar #'(lambda (name) + `(,name t)) + (union old-keys + (mapcar #'keyword-spec-name keys)))) + *)))) -- GitLab