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