diff --git a/code/env-access.lisp b/code/env-access.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b0c3f4d2388cd9a2b41e1ecc694ccfe854765cbe --- /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 cda0f79b09f2f2e3f7fb36021e76e3e1757f41fb..58d3d207d2c96b3e5989ae99b5b99398365c0603 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 7547ba6e3f9ac43a1233d64de2075cc85dc5f748..7fabd62bb77cab5a26832c5356de014ed266d2ae 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 3e5879d329409262f108b9b17271d9e1f861b708..0e55efbec3f5212a5c28192c0ecc58c61da4aa9c 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