From c20e6945c217c11d18e32e4012537bd74fa5ac98 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 2 Aug 2007 16:11:17 +0000
Subject: [PATCH] Environment access functions from CLtL2.  Not all of the
 functions specified in CLtL2 are implemented yet.  These functions live in
 the EXTENSIONS package.

code/env-access.lisp:
o The implementation.  (Based on code from SBCL)

code/exports.lisp:
o Export the symbols from the EXTENSIONS package.
o Import them into the C package.

tools/worldcom.lisp:
o Compile env-access.lisp;

tools/worldload.lisp:
o Load env-access.
---
 code/env-access.lisp | 196 +++++++++++++++++++++++++++++++++++++++++++
 code/exports.lisp    |  12 ++-
 tools/worldcom.lisp  |   3 +-
 tools/worldload.lisp |   4 +-
 4 files changed, 212 insertions(+), 3 deletions(-)
 create mode 100644 code/env-access.lisp

diff --git a/code/env-access.lisp b/code/env-access.lisp
new file mode 100644
index 000000000..b0c3f4d23
--- /dev/null
+++ b/code/env-access.lisp
@@ -0,0 +1,196 @@
+;;; -*- Mode: Lisp; Package: C; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/env-access.lisp,v 1.1 2007/08/02 16:11:17 rtoy Exp $")
+
+;;;
+;;; **********************************************************************
+;;;
+;;;   The environment access functions specified in Common Lisp the
+;;;   Language, 2nd edition.
+;;;
+
+(in-package "EXT")
+
+(export '(variable-information
+	  function-information
+	  declaration-information
+	  parse-macro))
+
+
+(in-package "C")
+
+(defun variable-information (var &optional env)
+  "Return three values. The first indicates a binding kind of VAR; the
+second is True if there is a local binding of VAR; the third is an
+alist of declarations that apply to the apparent binding of VAR."
+  (let* ((*lexical-environment* (or env (make-null-environment)))
+         (info (lexenv-find var variables)))
+    (etypecase info
+      (leaf
+       (let ((type (type-specifier
+		    (type-intersection
+		     (leaf-type info)
+		     (or (lexenv-find info type-restrictions)
+			 *universal-type*)))))
+	 (etypecase info
+	   (lambda-var
+	    (values :lexical t
+		    `((ignore . ,(lambda-var-ignorep info))
+		      (type . ,type)
+		      (dynamic-extent . ,(lambda-var-dynamic-extent info)))))
+	   (global-var
+	    (values :special t
+		    `((type . ,type))
+		    ))
+	   (constant
+	    (values :constant nil
+		    `((type . ,type))
+		    )))))
+      (cons
+       (values :symbol-macro t
+	       nil))
+      (null
+       (values (ecase (info variable kind var)
+		 (:special :special)
+		 (:constant :constant)
+		 (:macro :symbol-macro)
+		 (:global nil))
+	       nil
+	       `(
+		 (type . ,(type-specifier
+			   (info variable type var)))))))))
+
+(defun declaration-information (declaration-name &optional env)
+  (let ((env (or env (make-null-environment))))
+    (case declaration-name
+      (optimize
+       (let ((cookie (lexenv-cookie env)))
+	 (list (list 'speed (cookie-speed cookie))
+	       (list 'safety (cookie-safety cookie))
+	       (list 'compilation-speed (cookie-cspeed cookie))
+	       (list 'space (cookie-space cookie))
+	       (list 'debug (cookie-debug cookie))
+	       (list 'inhibit-warnings (cookie-brevity cookie))
+	       (list 'float-accuracy (cookie-float-accuracy cookie)))
+         ))
+      (ext:optimize-interface
+       (let ((cookie (lexenv-interface-cookie env)))
+	 (list (list 'speed (cookie-speed cookie))
+	       (list 'safety (cookie-safety cookie))
+	       (list 'compilation-speed (cookie-cspeed cookie))
+	       (list 'space (cookie-space cookie))
+	       (list 'debug (cookie-debug cookie))
+	       (list 'inhibit-warnings (cookie-brevity cookie))
+	       (list 'float-accuracy (cookie-float-accuracy cookie)))))
+      (t (error "Unsupported declaration ~S." declaration-name)))))
+
+(defun parse-macro (name lambda-list body &optional env)
+  (declare (ignore env))
+  (let ((whole (gensym "WHOLE-"))
+	(environment (gensym "ENVIRONMENT-")))
+    (multiple-value-bind (body decls)
+        (lisp::parse-defmacro lambda-list whole body name
+			      'parse-macro
+			      :environment environment)
+      `(lambda (,whole ,environment)
+         ,@decls
+         ,body))))
+
+(defun function-information (function &optional env)
+  (flet ((inlinealist (i)
+	   (ecase i
+	     (:inline
+	      (list '(inline . inline)))
+	     (:notinline
+	      (list '(inline . notinline)))
+	     (:maybe-inline
+	      (list '(inline . maybe-inline)))
+	     ((nil)
+	      nil))))
+    (let* ((*lexical-environment* (or env (make-null-environment)))
+	   (info (lexenv-find-function function)))
+      (etypecase info
+	(clambda
+	 (let ((type (type-specifier
+		      (type-intersection
+		       (leaf-type info)
+		       (or (lexenv-find info type-restrictions)
+			   *universal-type*)))))
+	   (values :function
+		   t
+		   (nconc (if (functional-dynamic-extent info)
+			      (list '(dynamic-extent . t)))
+			  (inlinealist (functional-inlinep info))
+			  (if (not (eq type 'function))
+			      (list `(ftype  . ,type)))))))
+	(cons
+	 (values :macro t nil))
+	(null
+	 (multiple-value-bind (kind kindp)
+	     (info function kind function)
+	   (cond  (kindp
+		   (ecase kind
+		     (:macro
+		      (values :macro nil nil))
+		     (:special-form
+		      (values :special-form nil nil))
+		     (:function
+		      (values
+		       :function
+		       nil
+		       (nconc (list `(ftype . ,(type-specifier (info function type function))))
+			      (inlinealist (info function inlinep function)))))))
+		  (t
+		   (if (eq kind :function)
+		       (values
+			:function
+			nil
+			(nconc (list `(ftype . ,(type-specifier (info function type function))))
+			       (inlinealist (info function inlinep function))))
+		   (values nil nil nil))))))
+	(defined-function
+	 (let ((type (type-specifier
+		      (type-intersection
+		       (defined-function-type info)
+		       (or (lexenv-find info type-restrictions)
+			   *universal-type*)))))
+	   (values :function
+		   nil
+		   (nconc (if (not (eq type 'function))
+			      (list `(ftype . ,type)))
+			  (inlinealist (defined-function-inlinep info ))))))))))
+
+#+(or)
+(defun augment-environment (env &key variable symbol-macro function macro declare)
+  (when (or macro symbol-macro)
+    (setq env (copy-structure env)))
+  (when macro
+    (setf (lexenv-functions env)
+          (nconc
+           (loop for (name def) in macro
+              collect (cons name (cons 'sys::macro def)))
+           (lexenv-functions env))))
+  (when symbol-macro
+    (setf (lexenv-variables env)
+          (nconc
+           (loop for (name def) in symbol-macro
+              collect (cons name (cons 'sys::macro def)))
+           (lexenv-variables env))))
+  (if (not (or variable function declare))
+      env
+      (handler-bind (((or style-warning)
+                      #'(lambda (c)
+                          (declare (ignore c))
+                          (invoke-restart 'muffle-warning))))
+        (eval-in-lexenv
+         `(flet ,(loop for fn in function collect `(,fn ()))
+            (let ,variable
+              (declare ,@declare)
+              (env)))
+         env))))
diff --git a/code/exports.lisp b/code/exports.lisp
index cda0f79b0..58d3d207d 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.258 2007/08/02 01:20:32 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.259 2007/08/02 16:11:17 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1210,6 +1210,7 @@
 	   "*DEFAULT-PRINT-FRAME-CALL-VERBOSITY*"))
 
 (intern "CHAR" "LISP")
+
 (defpackage "EXTENSIONS"
   (:nicknames "EXTENSIONS")
   (:import-from "LISP" "GET-SETF-METHOD")
@@ -1394,6 +1395,10 @@
 	     "BINARY-TEXT-STREAM" "READ-VECTOR" "WRITE-VECTOR"
 
 	     "INVALID-FASL")
+  (:export "VARIABLE-INFORMATION"
+	   "FUNCTION-INFORMATION"
+	   "DECLARATION-INFORMATION"
+	   "PARSE-MACRO")
   #+double-double
   (:export "DOUBLE-DOUBLE-FLOAT" "DD-PI"))
 
@@ -1532,6 +1537,11 @@
 		"STRING>*" "STRING>=*")
   (:import-from "SYSTEM" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS"
 		"FOREIGN-SYMBOL-DATA-ADDRESS")
+  (:import-from "EXTENSIONS"
+		"VARIABLE-INFORMATION"
+		"FUNCTION-INFORMATION"
+		"DECLARATION-INFORMATION"
+		"PARSE-MACRO")
   (:shadowing-import-from "KERNEL" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS"
 			  "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF")
   (:export "%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index 7547ba6e3..7fabd62bb 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.97 2006/06/30 18:41:32 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.98 2007/08/02 16:11:17 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -212,6 +212,7 @@
 (comf "target:code/misc")
 (comf "target:code/extensions" :byte-compile t)
 (comf "target:code/commandline")
+(comf "target:code/env-access")
 
 (unless (c:backend-featurep :gengc)
   (comf "target:code/dfixnum")
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 3e5879d32..0e55efbec 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.106 2006/10/29 10:08:42 cshapiro Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.107 2007/08/02 16:11:17 rtoy Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -118,6 +118,8 @@
 #-(or gengc runtime) (maybe-byte-load "code:room")
 (maybe-byte-load "code:stream-vector-io")
 
+(maybe-byte-load "code:env-access")
+
 ;;; Overwrite some cold-loaded stuff with byte-compiled versions, if any.
 #-(or gengc cgc)	; x86/cgc has stuff in static space.
 (progn
-- 
GitLab