From de1dd52e4b220cd03c809bd6229528f6078aab69 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 20 Apr 1991 14:20:06 +0000
Subject: [PATCH] Fixed WITH-COMPILATION-UNIT keyword to be :OVERRIDE instead
 of :FORCE. Also, added :OPTIMIZE and :OPTIMIZE-INTERFACE for changing the
 "global" compilation policy within the dynamic extent.

Added :CONTEXT-DECLARATIONS, which provides a way to insert declarations
conditional on pattern mathcing of the context in which the definition
appears.  So you can compiler all external functions safe, or whatever.
---
 code/macros.lisp | 161 ++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 153 insertions(+), 8 deletions(-)

diff --git a/code/macros.lisp b/code/macros.lisp
index 787af0e09..3fce31ac6 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.20 1991/02/08 13:34:07 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.21 1991/04/20 14:20:06 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.20 1991/02/08 13:34:07 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.21 1991/04/20 14:20:06 ram Exp $
 ;;;
 ;;; This file contains the macros that are part of the standard
 ;;; Spice Lisp environment.
@@ -1427,11 +1427,136 @@
 ;;;
 (defvar *aborted-compilation-units*)
 
-;;; With-Compilation-Unit  --  Public
+(declaim (special c::*context-declarations*))
+
+
+;;; EVALUATE-DECLARATION-CONTEXT  --  Internal
+;;;
+;;;    Recursively descend the context form, returning true if this subpart
+;;; matches the specified context.
 ;;;
+(defun evaluate-declaration-context (context name parent)
+  (let ((base (if (and (consp name) (consp (cdr name)))
+		  (cadr name)
+		  name)))
+    (if (atom context)
+	(let ((package (and (symbolp base) (symbol-package base))))
+	  (multiple-value-bind (ignore how)
+			       (if package
+				   (find-symbol (symbol-name base) package)
+				   (values nil nil))
+	    (declare (ignore ignore))
+	    (case context
+	      (:internal (eq how :internal))
+	      (:external (eq how :external))
+	      (:uninterned (and (symbolp base) (not package)))
+	      (:anonymous (not name))
+	      (:macro (eq parent 'defmacro))
+	      (:function (member parent '(defun labels flet function)))
+	      (:global (member parent '(defun defmacro function)))
+	      (:local (member parent '(labels flet)))
+	      (t
+	       (error "Unknown declaration context: ~S." context)))))
+	(case (first context)
+	  (:or
+	   (loop for x in (rest context)
+	     thereis (evaluate-declaration-context x name parent)))
+	  (:and
+	   (loop for x in (rest context)
+	     always (evaluate-declaration-context x name parent)))
+	  (:not
+	   (evaluate-declaration-context (second context) name parent))
+	  (:member
+	   (member name (rest context) :test #'equal))
+	  (:match
+	   (let ((name (concatenate 'string "$" (string base) "$")))
+	     (loop for x in (rest context)
+	       thereis (search (string x) name))))
+	  (t
+	   (error "Unknown declaration context: ~S." context))))))
+
+  
+;;; PROCESS-CONTEXT-DECLARATIONS  --  Internal
+;;;
+;;;    Given a list of context declaration specs, return a new value for
+;;; C::*CONTEXT-DECLARATIONS*.
+;;;
+(defun process-context-declarations (decls)
+  (append
+   (mapcar
+    #'(lambda (decl)
+	(unless (>= (length decl) 2)
+	  (error "Context declaration spec should have context and at ~
+	  least one DECLARE form:~%  ~S" decl))
+	#'(lambda (name parent)
+	    (when (evaluate-declaration-context (first decl) name parent)
+	      (rest decl))))
+    decls)
+   c::*context-declarations*))
+
+
+;;; With-Compilation-Unit  --  Public
 ;;;
 (defmacro with-compilation-unit (options &body body)
-  (let ((force nil)
+  "WITH-COMPILATION-UNIT ({Key Value}*) Form*
+  This form affects compilations that take place within its dynamic extent.  It
+  is intended to be wrapped around the compilation of all files in the same
+  system.  These keywords are defined:
+    :OVERRIDE Boolean-Form
+        One of the effects of this form is to delay undefined warnings 
+        until the end of the form, instead of giving them at the end of each
+        compilation.  If OVERRIDE is NIL (the default), then the outermost
+        WITH-COMPILATION-UNIT form grabs the undefined warnings.  Specifying
+        OVERRIDE true causes that form to grab any enclosed warnings, even if
+        it is enclosed by another WITH-COMPILATION-UNIT.
+    :OPTIMIZE Decl-Form
+        Decl-Form should evaluate to an OPTIMIZE declaration specifier.  This
+        declaration changes the `global' policy for compilations within the
+        body.
+    :OPTIMIZE-INTERFACE Decl-Form
+        Like OPTIMIZE, except that it specifies the value of the CMU extension
+        OPTIMIZE-INTERFACE policy (which controls argument type and syntax
+        checking.)
+    :CONTEXT-DECLARATIONS List-of-Context-Decls-Form
+        This is a CMU extension which allows compilation to be controlled
+        by pattern matching on the context in which a definition appears.  The
+        argument should evaluate to a list of lists of the form:
+            (Context-Spec Declare-Form+)
+        In the indicated context, the specified declare forms are inserted at
+        the head of each definition.  The declare forms for all contexts that
+	match are appended together, with earlier declarations getting
+	predecence over later ones.  A simple example:
+            :context-declarations
+            '((:external (declare (optimize (safety 2)))))
+        This will cause all functions that are named by external symbols to be
+        compiled with SAFETY 2.  The full syntax of context specs is:
+	:INTERNAL, :EXTERNAL
+	    True if the symbols is internal (external) in its home package.
+	:UNINTERNED
+	    True if the symbol has no home package.
+	:ANONYMOUS
+	    True if the function doesn't have any interesting name (not
+	    DEFMACRO, DEFUN, LABELS or FLET).
+	:MACRO, :FUNCTION
+	    :MACRO is a global (DEFMACRO) macro.  :FUNCTION is anything else.
+	:LOCAL, :GLOBAL
+	    :LOCAL is a LABELS or FLET.  :GLOBAL is anything else.
+	(:OR Context-Spec*)
+	    True in any specified context.
+	(:AND Context-Spec*)
+	    True only when all specs are true.
+	(:NOT Context-Spec)
+	    True when the spec is false.
+        (:MEMBER Name*)
+	    True when the name is one of these names (EQUAL test.)
+	(:MATCH Pattern*)
+	    True when any of the patterns is a substring of the name.  The name
+	    is wrapped with $'s, so $FOO matches names beginning with FOO,
+	    etc."
+  (let ((override nil)
+	(optimize nil)
+	(optimize-interface nil)
+	(context-declarations nil)
 	(n-fun (gensym))
 	(n-abort-p (gensym)))
     (when (oddp (length options))
@@ -1439,13 +1564,33 @@
     (do ((opt options (cddr opt)))
 	((null opt))
       (case (first opt)
-	(:force
-	 (setq force (second opt)))
+	(:override
+	 (setq override (second opt)))
+	(:optimize
+	 (setq optimize (second opt)))
+	(:optimize-interface
+	 (setq optimize-interface (second opt)))
+	(:context-declarations
+	 (setq context-declarations (second opt)))
 	(t
 	 (warn "Ignoring unknown option: ~S." (first opt)))))
 
-    `(flet ((,n-fun () ,@body))
-       (if (or ,force (not *in-compilation-unit*))
+    `(flet ((,n-fun ()
+	      (let (,@(when optimize
+			`((c::*default-cookie*
+			   (c::process-optimize-declaration
+			    ,optimize c::*default-cookie*))))
+		    ,@(when optimize-interface
+			`((c::*default-interface-cookie*
+			   (c::process-optimize-declaration
+			    ,optimize-interface
+			    c::*default-interface-cookie*))))
+		    ,@(when context-declarations
+			`((c::*context-declarations*
+			   (process-context-declarations
+			    ,context-declarations)))))
+		,@body)))
+       (if (or ,override (not *in-compilation-unit*))
 	   (let ((c::*undefined-warnings* nil)
 		 (c::*compiler-error-count* 0)
 		 (c::*compiler-warning-count* 0)
-- 
GitLab