Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

Commit [6a91d3] Maximize Restore History

Refactored code so that it is shared by cmp and new-cmp:

* Use the new proclamations/sysfun.lsp files from the new compiler.
* We split src/cmp/cmpdefs.lsp into cmpdefs, cmppackage, cmptypes and cmpglobals
* Split cmpform.lsp out of cmpmac.lsp
* Merged in {cmp,new-cmp}/cmpc-wt.lsp some of the cmpmac wt routines
* Use functions instead of macros for the WT-* operations
* Split out from *cmp/cmpenv.lsp a file cmppolicy.lsp
* A single file, cmpenv-api.lsp for the manipulation of environments.
* The type comparison functions go into cmptype-arith.lsp and are cached.
* The code that propagates types in function calls goes into cmptype-prop.lsp.
* The remainings of cmpenv go into cmpenv-{declare,proclaim,declaim}.

Associated fixes:
* Fixed typo and wrong proclamation for SI:GET-SYSPROP.
* Fixed typo in SIMPLIFY-ARITHMETIC.
* Explicitely set the debug level when building ECL
* All declarations are stored in the compiler environment.
* Each function and form stores the compilation environment.
* Declaration POLICY-DEBUG-IHS-FRAME is acts only on the function environment.
* Make the definition if ihs_env only happen when it is used.
* Eliminated *notinline*, *inline-functions* and *function-declarations*
* Slightly more efficient creation of accessors in kernel.lsp
* Remove the proxy C2DECL-BODY
* Fix the order of declarations in SI:PROCESS-DECLARATIONS
* Reimplemented C1BODY using SI:PROCESS-DECLARATIONS
* DECLAIM's proclamation do not propagate beyond the compiled file.

Juan Jose Garcia Ripoll Juan Jose Garcia Ripoll 2010-05-01

1 2 3 > >> (Page 1 of 3)
added src/cmp/cmpc-wt.lsp
added src/cmp/cmpenv-api.lsp
added src/cmp/cmpenv-fun.lsp
added src/cmp/cmpenv-proclaim.lsp
added src/cmp/cmppackage.lsp
added src/cmp/cmppolicy.lsp
added src/cmp/cmptype-prop.lsp
removed src/new-cmp/sysfun.lsp
changed src
changed src/CHANGELOG
changed src/bare.lsp.in
changed src/c
changed src/c/compiler.d
changed src/clos
changed src/clos/kernel.lsp
changed src/cmp
changed src/cmp/cmpcall.lsp
changed src/cmp/cmpcatch.lsp
changed src/cmp/cmpdefs.lsp
changed src/cmp/cmpeval.lsp
changed src/cmp/cmpflet.lsp
changed src/cmp/cmpinline.lsp
changed src/cmp/cmplam.lsp
changed src/cmp/cmplet.lsp
changed src/cmp/cmpmac.lsp
changed src/cmp/cmpmulti.lsp
changed src/cmp/cmpnum.lsp
changed src/cmp/cmpprop.lsp
changed src/cmp/cmptag.lsp
changed src/cmp/cmptop.lsp
changed src/cmp/cmptype.lsp
changed src/cmp/cmputil.lsp
changed src/cmp/cmpwt.lsp
changed src/cmp/load.lsp.in
changed src/cmp/proclamations.lsp
changed src/compile.lsp.in
changed src/configure
changed src/configure.in
changed src/new-cmp
changed src/new-cmp/cmpc-inline.lsp
changed src/new-cmp/cmplam.lsp
changed src/new-cmp/cmptype.lsp
changed src/new-cmp/load.lsp.in
copied src/cmp/cmpenv.lsp -> src/cmp/cmptype-arith.lsp
copied src/new-cmp/cmpc-wt.lsp -> src/cmp/cmpform.lsp
copied src/new-cmp/cmpdefs.lsp -> src/cmp/cmpenv-declaim.lsp
copied src/new-cmp/cmpenv.lsp -> src/cmp/cmpglobals.lsp
copied src/new-cmp/cmpglobals.lsp -> src/cmp/cmptypes.lsp
copied src/new-cmp/cmptypes.lsp -> src/cmp/cmpenv-declare.lsp
src/cmp/cmpc-wt.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpenv-api.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpenv-fun.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpenv-proclaim.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmppackage.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmppolicy.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmptype-prop.lsp Diff Switch to side-by-side view
Loading...
src/new-cmp/sysfun.lsp
File was removed.
src
Directory.
src/CHANGELOG Diff Switch to side-by-side view
Loading...
src/bare.lsp.in Diff Switch to side-by-side view
Loading...
src/c
Directory.
src/c/compiler.d Diff Switch to side-by-side view
Loading...
src/clos
Directory.
src/clos/kernel.lsp Diff Switch to side-by-side view
Loading...
src/cmp
Directory.
src/cmp/cmpcall.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpcatch.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpdefs.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpeval.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpflet.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpinline.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmplam.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmplet.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpmac.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpmulti.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpnum.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpprop.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmptag.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmptop.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmptype.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmputil.lsp Diff Switch to side-by-side view
Loading...
src/cmp/cmpwt.lsp Diff Switch to side-by-side view
Loading...
src/cmp/load.lsp.in Diff Switch to side-by-side view
Loading...
src/cmp/proclamations.lsp Diff Switch to side-by-side view
Loading...
src/compile.lsp.in Diff Switch to side-by-side view
Loading...
src/configure Diff Switch to side-by-side view
Loading...
src/configure.in Diff Switch to side-by-side view
Loading...
src/new-cmp
Directory.
src/new-cmp/cmpc-inline.lsp Diff Switch to side-by-side view
Loading...
src/new-cmp/cmplam.lsp Diff Switch to side-by-side view
Loading...
src/new-cmp/cmptype.lsp Diff Switch to side-by-side view
Loading...
src/new-cmp/load.lsp.in Diff Switch to side-by-side view
Loading...
src/cmp/cmpenv.lsp to src/cmp/cmptype-arith.lsp
--- a/src/cmp/cmpenv.lsp
+++ b/src/cmp/cmptype-arith.lsp
@@ -10,679 +10,320 @@
 ;;;;
 ;;;;    See file '../Copyright' for full details.
 
-;;;; CMPENV  Environments of the Compiler.
-
-(in-package "COMPILER")
-
-;;; Only these flags are set by the user.
-;;; If (safe-compile) is ON, some kind of run-time checks are not
-;;; included in the compiled code.  The default value is OFF.
-
-(defconstant +init-env-form+
-  '((*gensym-counter* 0)
-    (*compiler-in-use* t)
-    (*compiler-phase* 't1)
-    (*callbacks* nil)
-    (*max-temp* 0)
-    (*temp* 0)
-    (*next-cmacro* 0)
-    (*next-cfun* 0)
-    (*last-label* 0)
-    (*load-objects* (make-hash-table :size 128 :test #'equal))
-    (*make-forms* nil)
-    (*static-constants* nil)
-    (*permanent-objects* nil)
-    (*temporary-objects* nil)
-    (*local-funs* nil)
-    (*global-var-objects* nil)
-    (*global-vars* nil)
-    (*global-funs* nil)
-    (*global-cfuns-array* nil)
-    (*linking-calls* nil)
-    (*global-entries* nil)
-    (*undefined-vars* nil)
-    (*reservations* nil)
-    (*top-level-forms* nil)
-    (*compile-time-too* nil)
-    (*clines-string-list* '())
-    (*inline-functions* nil)
-    (*inline-blocks* 0)
-    (*notinline* nil)
-    (*debugger-hook* 'compiler-debugger)))
-
-(defun next-lcl () (list 'LCL (incf *lcl*)))
-
-(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
-  (let ((code (incf *next-cfun*)))
-    (format nil prefix code (lisp-to-c-name lisp-name))))
-
-(defun next-temp ()
-  (prog1 *temp*
-         (incf *temp*)
-         (setq *max-temp* (max *temp* *max-temp*))))
-
-(defun next-lex ()
-  (prog1 (cons *level* *lex*)
-         (incf *lex*)
-         (setq *max-lex* (max *lex* *max-lex*))))
-
-(defun next-env () (prog1 *env*
-		     (incf *env*)
-		     (setq *max-env* (max *env* *max-env*))))
-
-(defun function-arg-types (arg-types &aux (types nil))
-  (do ((al arg-types (cdr al)))
-      ((or (endp al)
-           (member (car al) '(&optional &rest &key)))
-       (nreverse types))
-      (declare (object al))
-      (push (type-filter (car al)) types)))
-
-;;; The valid return type declaration is:
-;;;	(( VALUES {type}* )) or ( {type}* ).
-
-(defun function-return-type (return-types)
-  (cond ((endp return-types) t)
-        ((and (consp (car return-types))
-              (eq (caar return-types) 'VALUES))
-         (cond ((not (endp (cdr return-types)))
-                (warn "The function return types ~s is illegal." return-types)
-                t)
-               ((or (endp (cdar return-types))
-                    (member (cadar return-types) '(&optional &rest &key)))
-                t)
-               (t (type-filter (car return-types) t))))
-        (t (type-filter (car return-types)))))
-
-(defun add-function-proclamation (fname decl)
-  (if (si:valid-function-name-p fname)
-      (let* ((arg-types '*)
-	     (return-types '*)
-	     (l decl))
-	(cond ((null l))
-	      ((consp l)
-	       (setf arg-types (pop l)))
-	      (t (warn "The function proclamation ~s ~s is not valid."
-		       fname decl)))
-	(cond ((null l))
-	      ((and (consp l) (null (rest l)))
-	       (setf return-types (function-return-type l)))
-	      (t (warn "The function proclamation ~s ~s is not valid."
-		       fname decl)))
-	(if (eq arg-types '*)
-	    (rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
-	    (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
-	(if (eq return-types '*)
-	    (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
-	    (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
-      (warn "The function proclamation ~s ~s is not valid." fname decl)))
-
-(defun add-function-declaration (fname arg-types return-types)
-  (if (si::valid-function-name-p fname)
-      (let ((fun (cmp-env-search-function fname)))
-	(if (functionp fun)
-	    (warn "Found function declaration for local macro ~A" fname)
-	    (push (list fun
-			(function-arg-types arg-types)
-			(function-return-type return-types))
-		  *function-declarations*)))
-      (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))
-
-(defun get-arg-types (fname)
-  (let ((x (assoc fname *function-declarations*)))
-    (if x
-	(values (second x) t)
-	(get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
-
-(defun get-return-type (fname)
-  (let ((x (assoc fname *function-declarations*)))
-    (if x
-	(values (third x) t)
-	(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
-
-(defun get-local-arg-types (fun &aux x)
-  (if (setq x (assoc fun *function-declarations*))
-      (values (second x) t)
-      (values nil nil)))
-
-(defun get-local-return-type (fun &aux x)
-  (if (setq x (assoc fun *function-declarations*))
-      (values (caddr x) t)
-      (values nil nil)))
-
-(defun get-proclaimed-narg (fun)
-  (multiple-value-bind (arg-list found)
-      (get-arg-types fun)
-    (if found
-	(loop for type in arg-list
-	   with minarg = 0
-	   and maxarg = 0
-	   and in-optionals = nil
-	   do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
-		     (return (values minarg call-arguments-limit)))
-		    ((eq type '&optional)
-		     (setf in-optionals t maxarg minarg))
-		    (in-optionals
-		     (incf maxarg))
-		    (t
-		     (incf minarg)
-		     (incf maxarg)))
-	   finally (return (values minarg maxarg)))
-	(values 0 call-arguments-limit))))
-
-;;; Proclamation and declaration handling.
-
-(defun inline-possible (fname)
-  (not (or ; (compiler-<push-events)
-	;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
-	(member fname *notinline* :test #'same-fname-p)
-	(get-sysprop fname 'CMP-NOTINLINE))))
-
-#-:CCL
-(defun proclaim (decl &aux decl-name)
-  (unless (listp decl)
-	  (error "The proclamation specification ~s is not a list" decl))
-  (case (setf decl-name (car decl))
-    (SPECIAL
-     (dolist (var (cdr decl))
-       (if (symbolp var)
-           (sys:*make-special var)
-           (error "Syntax error in proclamation ~s" decl))))
-    (OPTIMIZE
-     (dolist (x (cdr decl))
-       (when (symbolp x) (setq x (list x 3)))
-       (if (or (not (consp x))
-               (not (consp (cdr x)))
-               (not (numberp (second x)))
-               (not (<= 0 (second x) 3)))
-           (warn "The OPTIMIZE proclamation ~s is illegal." x)
-           (case (car x)
-		 (DEBUG (setq *debug* (second x)))
-                 (SAFETY (setq *safety* (second x)))
-                 (SPACE (setq *space* (second x)))
-                 (SPEED (setq *speed* (second x)))
-                 (COMPILATION-SPEED (setq *speed* (- 3 (second x))))
-                 (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
-    (TYPE
-     (if (consp (cdr decl))
-         (proclaim-var (second decl) (cddr decl))
-         (error "Syntax error in proclamation ~s" decl)))
-    (FTYPE
-     (if (atom (rest decl))
-	 (error "Syntax error in proclamation ~a" decl)
-	 (multiple-value-bind (type-name args)
-	     (si::normalize-type (second decl))
-	   (if (eq type-name 'FUNCTION)
-	       (dolist (v (cddr decl))
-		 (add-function-proclamation v args))
-	       (error "In an FTYPE proclamation, found ~A which is not a function type."
-		      (second decl))))))
-    (INLINE
-     (dolist (fun (cdr decl))
-       (if (si::valid-function-name-p fun)
-	   (rem-sysprop fun 'CMP-NOTINLINE)
-	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
-    (NOTINLINE
-     (dolist (fun (cdr decl))
-       (if (si::valid-function-name-p fun)
-	   (put-sysprop fun 'CMP-NOTINLINE t)
-	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
-    ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
-     ;; FIXME! IGNORED!
-     (dolist (var (cdr decl))
-       (unless (si::valid-function-name-p var)
-	 (error "Not a valid function name ~s in ~s proclamation" fun decl-name))))
-    (DECLARATION
-     (do-declaration (rest decl) #'error))
-    (SI::C-EXPORT-FNAME
-     (dolist (x (cdr decl))
-       (cond ((symbolp x)
-	      (multiple-value-bind (found c-name)
-		  (si::mangle-name x t)
-		(if found
-		    (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
-		    (put-sysprop x 'Lfun c-name))))
-	     ((consp x)
-	      (destructuring-bind (c-name lisp-name) x
-		(if (si::mangle-name lisp-name)
-		    (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
-		    (put-sysprop lisp-name 'Lfun c-name))))
-	     (t
-	      (error "Syntax error in proclamation ~s" decl)))))
-    ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION
-      COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
-      LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
-      READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR
-      SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING
-      SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
-     (proclaim-var decl-name (cdr decl)))
-    (otherwise
-     (cond ((member (car decl) si:*alien-declarations*))
-	   ((multiple-value-bind (ok type)
-		(valid-type-specifier decl-name)
-	      (when ok
-		(proclaim-var type (rest decl))
-		t)))
-	   ((let ((proclaimer (get-sysprop (car decl) :proclaim)))
-	      (when (functionp proclaimer)
-		(mapc proclaimer (rest decl))
-		t)))
-	   (t
-	    (warn "The declaration specifier ~s is unknown." decl-name))))))
-
-(defun type-name-p (name)
-  (or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
-      (find-class name nil)
-      (get-sysprop name 'SI::STRUCTURE-TYPE)))
-
-(defun do-declaration (names-list error)
-  (declare (si::c-local))
-  (dolist (new-declaration names-list)
-    (unless (symbolp new-declaration)
-      (cmperr "The declaration ~s is not a symbol" new-declaration))
-    (when (type-name-p new-declaration)
-      (cmperr "Symbol name ~S cannot be both the name of a type and of a declaration"
-              new-declaration))
-    (pushnew new-declaration si:*alien-declarations*)))
-
-(defun proclaim-var (type vl)
-  (setq type (type-filter type))
-  (dolist (var vl)
-    (if (symbolp var)
-	(let ((type1 (get-sysprop var 'CMP-TYPE))
-	      (v (sch-global var)))
-	  (setq type1 (if type1 (type-and type1 type) type))
-	  (when v (setq type1 (type-and type1 (var-type v))))
-	  (unless type1
-	    (warn
-	     "Inconsistent type declaration was found for the variable ~s."
-	     var)
-	    (setq type1 T))
-	  (put-sysprop var 'CMP-TYPE type1)
-	  (when v (setf (var-type v) type1)))
-	(warn "The variable name ~s is not a symbol." var))))
-
-(defun parse-ignore-declaration (decl-args expected-ref-number)
-  (loop with output = '()
-     for name in decl-args
-     do (cond ((symbolp name)
-               (push (cons name expected-ref-number) output))
-              (t
-               (cmpassert (and (consp name)
-                               (= (length name) 2)
-                               (eq (first name) 'function))
-                          "Invalid argument to IGNORE/IGNORABLE declaration:~&~A"
-                          name)))
-     finally (return output)))
-
-(defun c1body (body doc-p &aux
-	            (all-declarations nil)
-		    (ss nil)		; special vars
-		    (is nil)		; ignored vars
-		    (ts nil)		; typed vars (var . type)
-		    (others nil)	; all other vars
-	            doc form)
-  (loop
-    (when (endp body) (return))
-    (setq form (cmp-macroexpand (car body)))
-    (cond
-     ((stringp form)
-      (when (or (null doc-p) (endp (cdr body)) doc) (return))
-      (setq doc form))
-     ((and (consp form) (eq (car form) 'DECLARE))
-      (push form all-declarations)
-      (dolist (decl (cdr form))
-        (cmpassert (and (proper-list-p decl) (symbolp (first decl)))
-		   "Syntax error in declaration ~s" form)
-	(let* ((decl-name (first decl))
-	       (decl-args (rest decl)))
-	  (flet ((declare-variables (type var-list)
-		   (cmpassert (proper-list-p var-list #'symbolp)
-			      "Syntax error in declaration ~s" decl)
-		   (when type
-		     (dolist (var var-list)
-		       (push (cons var type) ts)))))
-	    (case decl-name
-	      (SPECIAL
-	       (cmpassert (proper-list-p decl-args #'symbolp)
-			  "Syntax error in declaration ~s" decl)
-	       (setf ss (append decl-args ss)))
-	      (IGNORE
-               (setf is (nconc (parse-ignore-declaration decl-args -1)
-                               is)))
-	      (IGNORABLE
-	       (setf is (nconc (parse-ignore-declaration decl-args 0)
-                               is)))
-	      (TYPE
-	       (cmpassert decl-args "Syntax error in declaration ~s" decl)
-	       (declare-variables (first decl-args) (rest decl-args)))
-	      (OBJECT
-	       (declare-variables 'OBJECT decl-args))
-	      ;; read-only variable treatment. obsolete!
-	      (:READ-ONLY
-	       (push decl others))
-	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
-		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
-                POLICY-DEBUG-IHS-FRAME)
-	       (push decl others))
-	      (otherwise
-	       (if (member decl-name si::*alien-declarations*)
-		 (push decl others)
-		 (multiple-value-bind (ok type)
-		     (valid-type-specifier decl-name)
-		   (cmpassert ok "The declaration specifier ~s is unknown." decl-name)
-		   (declare-variables type decl-args))))
-	      )))))
-     (t (return)))
-    (pop body)
-    )
-  (values body ss ts is others doc all-declarations)
-  )
-
-(defun default-optimization (optimization)
-  (ecase optimization
-    (speed *speed*)
-    (safety *safety*)
-    (space *space*)
-    (debug *debug*)))
-
-(defun search-optimization-quality (declarations what)
-  (dolist (i (reverse declarations)
-	   (default-optimization what))
-    (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
-               (eq what 'debug))
-      (return 2))      
-    (when (and (consp i) (eq (first i) 'optimize))
-      (dolist (j (rest i))
-	(cond ((consp j)
-	       (when (eq (first j) what)
-		 (return-from search-optimization-quality (second j))))
-	      ((eq j what)
-	       (return-from search-optimization-quality 3)))))))
-
-(defun c1add-declarations (decls &aux (dl nil) (optimizations))
-  (dolist (decl decls)
-    (case (car decl)
-      (OPTIMIZE
-       (push decl dl)
-       (dolist (x (cdr decl))
-	 (when (symbolp x) (setq x (list x 3)))
-	 (unless optimizations
-	   (setq optimizations (cmp-env-all-optimizations)))
-	 (if (or (not (consp x))
-		 (not (consp (cdr x)))
-		 (not (numberp (second x)))
-		 (not (<= 0 (second x) 3)))
-	   (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
-	   (let ((value (second x)))
-	     (case (car x)
-	       (DEBUG (setf (first optimizations) value))
-	       (SAFETY (setf (second optimizations) value))
-	       (SPACE (setf (third optimizations) value))
-	       (SPEED (setf (fourth optimizations) value))
-	       (COMPILATION-SPEED)
-	       (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))))
-      (POLICY-DEBUG-IHS-FRAME
-       (unless optimizations
-         (setq optimizations (cmp-env-all-optimizations)))
-       (setf (first optimizations) (max 2 (first optimizations))))
-      (FTYPE
-       (if (atom (rest decl))
-	   (cmpwarn "Syntax error in declaration ~a" decl)
-	   (multiple-value-bind (type-name args)
-	       (si::normalize-type (second decl))
-	     (if (eq type-name 'FUNCTION)
-		 (dolist (v (cddr decl))
-		   (add-function-declaration v (first args) (rest args)))
-		 (cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
-			  (second decl))))))
-      (INLINE
-       (push decl dl)
-       (dolist (fun (cdr decl))
-	 (if (si::valid-function-name-p fun)
-	   (setq *notinline* (remove fun *notinline*))
-	   (cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
-      (NOTINLINE
-       (push decl dl)
-       (dolist (fun (cdr decl))
-	 (if (si::valid-function-name-p fun)
-	   (push fun *notinline*)
-	   (cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
-      (DECLARATION
-       (do-declaration (rest decl) #'cmperr))
-      ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE))
-      ((DYNAMIC-EXTENT IGNORABLE)
-       ;; FIXME! SOME ARE IGNORED!
-       )
-      (:READ-ONLY)
-      (otherwise
-       (unless (member (car decl) si:*alien-declarations*)
-	 (cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
-  (when optimizations
-    (setf *cmp-env*
-	  (cons (cons `(:declare optimize ,@optimizations)
-		      (car *cmp-env*))
-		(cdr *cmp-env*))))
-  dl)
-
-(defun c1decl-body (decls body)
-  (if (null decls)
-      (c1progn body)
-      (let* ((*function-declarations* *function-declarations*)
-	     (si:*alien-declarations* si:*alien-declarations*)
-	     (*notinline* *notinline*)
-	     (*cmp-env* *cmp-env*)
-	     (dl (c1add-declarations decls)))
-	(setq body (c1progn body))
-	(make-c1form 'DECL-BODY body dl body))))
-
-(put-sysprop 'decl-body 'c2 'c2decl-body)
-
-(defun c2decl-body (decls body)
-  (let ((*cmp-env* *cmp-env*)
-        (*notinline* *notinline*))
-    (c1add-declarations decls)
-    (c2expr body)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; COMPILER ENVIRONMENT
-;;;
-
-(defmacro cmp-env-new ()
-  '(cons nil nil))
-
-(defun cmp-env-copy (&optional (env *cmp-env*))
-  (cons (car env) (cdr env)))
-
-(defmacro cmp-env-variables (&optional (env '*cmp-env*))
-  `(car ,env))
-
-(defmacro cmp-env-functions (&optional (env '*cmp-env*))
-  `(cdr ,env))
-
-(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t))
-  (push (list (var-name var)
-	      (if (member (var-kind var) '(special global))
-		  :special
-		  t)
-	      boundp
-	      var)
-	(cmp-env-variables)))
-
-(defun cmp-env-declare-special (name &optional (env *cmp-env*))
-  (cmp-env-register-var (c1make-global-variable name :warn nil :kind 'SPECIAL)
-			env nil))
-
-(defun cmp-env-register-function (fun &optional (env *cmp-env*))
-  (push (list (fun-name fun) 'function fun)
-	(cmp-env-functions env)))
-
-(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
-  (push (list name 'si::macro function)
-	(cmp-env-functions env)))
-
-(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
-  (push (list name 'si::symbol-macro #'(lambda (whole env) form))
-	(cmp-env-variables env)))
-
-(defun cmp-env-register-block (blk &optional (env *cmp-env*))
-  (push (list :block (blk-name blk) blk)
-	(cmp-env-variables env)))
-
-(defun cmp-env-register-tag (tag &optional (env *cmp-env*))
-  (push (list :tag (list (tag-name tag)) tag)
-	(cmp-env-variables env)))
-
-(defun cmp-env-search-function (name &optional (env *cmp-env*))
-  (let ((ccb nil)
-	(clb nil)
-	(unw nil)
-	(found nil))
-    (dolist (record (cmp-env-functions env))
-      (cond ((eq record 'CB)
-	     (setf ccb t))
-	    ((eq record 'LB)
-	     (setf clb t))
-	    ((eq record 'UNWIND-PROTECT)
-	     (setf unw t))
-	    ((atom record)
-	     (baboon))
-	    ;; We have to use EQUAL because the name can be a list (SETF whatever)
-	    ((equal (first record) name)
-	     (setf found (first (last record)))
-	     (return))))
-    (values found ccb clb unw)))
-
-(defun cmp-env-search-variables (type name env)
-  (let ((ccb nil)
-	(clb nil)
-	(unw nil)
-	(found nil))
-    (dolist (record (cmp-env-variables env))
-      (cond ((eq record 'CB)
-	     (setf ccb t))
-	    ((eq record 'LB)
-	     (setf clb t))
-	    ((eq record 'UNWIND-PROTECT)
-	     (setf unw t))
-	    ((atom record)
-	     (baboon))
-	    ((not (eq (first record) type)))
-	    ((eq type :block)
-	     (when (eq name (second record))
-	       (setf found record)
-	       (return)))
-	    ((eq type :tag)
-	     (when (member name (second record) :test #'eql)
-	       (setf found record)
-	       (return)))
-            ((eq name 'si::symbol-macro)
-             (when (eq (second record) 'si::symbol-macro)
-	       (setf found record))
-	     (return))
-	    (t
-	     (setf found record)
-	     (return))))
-    (values (first (last found)) ccb clb unw)))
-
-(defun cmp-env-search-block (name &optional (env *cmp-env*))
-  (cmp-env-search-variables :block name env))
-
-(defun cmp-env-search-tag (name &optional (env *cmp-env*))
-  (cmp-env-search-variables :tag name env))
-
-(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*))
-  (cmp-env-search-variables name 'si::symbol-macro env))
-
-(defun cmp-env-search-var (name &optional (env *cmp-env*))
-  (cmp-env-search-variables name t env))
-
-(defun cmp-env-search-macro (name &optional (env *cmp-env*))
-  (let ((f (cmp-env-search-function name env)))
-    (if (functionp f) f nil)))
-
-(defun cmp-env-mark (mark &optional (env *cmp-env*))
-  (cons (cons mark (car env))
-	(cons mark (cdr env))))
-
-(defun cmp-env-new-variables (new-env old-env)
-  (loop for i in (ldiff (cmp-env-variables *cmp-env*)
-			(cmp-env-variables old-env))
-	when (and (consp i) (var-p (fourth i)))
-	collect (fourth i)))
-
-(defun symbol-macro-declaration-p (name type)
-  (let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*)))
-    (when (and record (functionp record))
-      (let* ((expression (funcall record name nil)))
-        (cmp-env-register-symbol-macro name `(the ,type ,expression)))
-      t)))
-
-(defun check-vdecl (vnames ts is)
-  (loop for (var . type) in ts
-     unless (or (member var vnames :test #'eq)
-                (symbol-macro-declaration-p var type))
-     do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
-                 type var))
-  (loop for (var . expected-uses) in is
-     unless (member var vnames :test #'eq)
-     do (cmpwarn (if (minusp expected-uses)
-                     "IGNORE declaration was found for not bound variable ~s."
-                     "IGNORABLE declaration was found for not bound variable ~s.")
-                 var)))
-
-(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
-  (loop for i in (car env)
-     when (and (consp i)
-	       (eq (first i) :declare)
-	       (eq (second i) 'optimize))
-     do (return (cddr i))
-     finally (return (list *debug* *safety* *space* *speed*))))
-
-(defun cmp-env-optimization (property &optional (env *cmp-env*))
-  (let ((x (cmp-env-all-optimizations env)))
-    (case property
-      (debug (first x))
-      (safety (second x))
-      (space (third x))
-      (speed (fourth x)))))
-
-(defun policy-assume-right-type (&optional (env *cmp-env*))
-  (< (cmp-env-optimization 'safety env) 2))
-
-(defun policy-check-stack-overflow (&optional (env *cmp-env*))
-  "Do we add a stack check to every function?"
-  (>= (cmp-env-optimization 'safety env) 2))
-
-(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
-  "Do we inline access to structures and sealed classes?"
-  (or (< (cmp-env-optimization 'safety env) 2)
-      (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
-
-(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
-  "Do we assume that arguments are the right type?"
-  (> (cmp-env-optimization 'safety env) 1))
-
-(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
-  "Do we generate CHECK-TYPE forms for function arguments with type declarations?"
-  (and *automatic-check-type-in-lambda*
-       (>= (cmp-env-optimization 'safety env) 1)))
-
-(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
-  "Do we assume that type and class definitions will not change?"
-  (<= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
-  "Do we inline access to arrays?"
-  (< (cmp-env-optimization 'safety env) 2))
-
-(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
-  "Check access to array bounds?"
-  (>= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
-  "Shall we create an IHS frame so that this function shows up in backtraces?"
-  ;; Note that this is a prerequisite for registering variable bindings. Hence,
-  ;; it has to be recorded in a special variable.
-  (>= (fun-debug *current-function*) 2))+;;;; CMPTYPE-ARITH -- Operations upon and among types
+
+(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES")
+
+;;; CL-TYPE is any valid type specification of Common Lisp.
+;;;
+;;; TYPE is a representation type used by ECL.  TYPE is one of:
+;;;
+;;;				T(BOOLEAN)
+;;;
+;;;	FIXNUM  CHARACTER  SINGLE-FLOAT  DOUBLE-FLOAT
+;;;	(VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)
+;;;	(VECTOR SINGLE-FLOAT)  (VECTOR DOUBLE-FLOAT)
+;;;	(ARRAY T)  (ARRAY BASE-CHAR)  (ARRAY BIT)
+;;;	(ARRAY FIXNUM)
+;;;	(ARRAY SINGLE-FLOAT)  (ARRAY DOUBLE-FLOAT)
+;;;	STANDARD-OBJECT STRUCTURE-OBJECT
+;;;	SYMBOL
+;;;	UNKNOWN
+;;;
+;;;				NIL
+;;;
+;;;
+;;; immediate-type:
+;;;	FIXNUM		int
+;;;	CHARACTER	char
+;;;	SINGLE-FLOAT	float
+;;;	DOUBLE-FLOAT	double
+
+(deftype any () 't)
+
+(defun member-type (type disjoint-supertypes)
+  (member type disjoint-supertypes :test #'subtypep))
+
+;;; Check if THING is an object of the type TYPE.
+;;; Depends on the implementation of TYPE-OF.
+;;; (only used for saving constants?)
+#-new-cmp
+(defun object-type (thing)
+  (let ((type (if thing (type-of thing) 'SYMBOL)))
+    (case type
+      ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
+      ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
+      ((STRING BASE-STRING BIT-VECTOR) type)
+      (VECTOR (list 'VECTOR (array-element-type thing)))
+      (ARRAY (list 'ARRAY (array-element-type thing)))
+      #+clos
+      (STANDARD-OBJECT 'STANDARD-OBJECT)
+      #+clos
+      (STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
+      (t t))))
+
+(defun type-filter (type &optional values-allowed)
+  (multiple-value-bind (type-name type-args) (sys::normalize-type type)
+    (case type-name
+        ((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name)
+        (SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT)
+        (LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT)
+        ((SIMPLE-STRING STRING) 'STRING)
+        ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR)
+	((NIL T) t)
+	((SIMPLE-ARRAY ARRAY)
+	 (cond ((endp type-args) '(ARRAY *))		; Beppe
+	       ((eq '* (car type-args)) t)
+	       (t (let ((element-type (upgraded-array-element-type (car type-args)))
+			(dimensions (if (cdr type-args) (second type-args) '*)))
+		    (if (and (not (eq dimensions '*))
+			     (or (numberp dimensions)
+				 (= (length dimensions) 1)))
+		      (case element-type
+			(BASE-CHAR 'STRING)
+			(BIT 'BIT-VECTOR)
+			(t (list 'VECTOR element-type)))
+		      (list 'ARRAY element-type))))))
+	(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
+	((STREAM CONS) type-name) ; Juanjo
+        (FUNCTION type-name)
+	(t (cond ((eq type-name 'VALUES)
+		  (unless values-allowed
+		    (error "VALUES type found in a place where it is not allowed."))
+		  `(VALUES ,@(mapcar #'(lambda (x)
+					(if (or (eq x '&optional)
+						(eq x '&rest))
+					    x
+					    (type-filter x)))
+				    type-args)))
+		 #+clos
+		 ((subtypep type 'STANDARD-OBJECT) type)
+		 #+clos
+		 ((subtypep type 'STRUCTURE-OBJECT) type)
+		 ((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
+                               #+short-float SHORT-FLOAT #+long-float LONG-FLOAT
+			       (VECTOR T) STRING BIT-VECTOR
+			       (VECTOR FIXNUM) (VECTOR SINGLE-FLOAT)
+			       (VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR)
+			       (ARRAY BIT) (ARRAY FIXNUM)
+			       (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
+			       (ARRAY T))) ; Beppe
+		    (when (subtypep type v) (return v))))
+		 ((and (eq type-name 'SATISFIES) ; Beppe
+		       (symbolp (car type-args))
+		       (sys:get-sysprop (car type-args) 'TYPE-FILTER)))
+		 (t t))))))
+
+(defun valid-type-specifier (type)
+  (handler-case
+     (if (subtypep type 'T)
+	 (values t (type-filter type))
+         (values nil nil))
+    (error (c) (values nil nil))))
+
+(defun known-type-p (type)
+  (subtypep type 'T))
+
+(defun-equal-cached type-and (t1 t2)
+  ;; FIXME! Should we allow "*" as type name???
+  (when (or (eq t1 t2) (eq t2 '*))
+    (return-from type-and t1))
+  (when (eq t1 '*)
+    (return-from type-and t2))
+  (let* ((si::*highest-type-tag* si::*highest-type-tag*)
+	 (si::*save-types-database* t)
+	 (si::*member-types* si::*member-types*)
+	 (si::*elementary-types* si::*elementary-types*)
+	 (tag1 (si::safe-canonical-type t1))
+	 (tag2 (si::safe-canonical-type t2)))
+    (cond ((and (numberp tag1) (numberp tag2))
+	   (setf tag1 (si::safe-canonical-type t1)
+		 tag2 (si::safe-canonical-type t2))
+	   (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
+		  NIL)
+		 ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
+		  t1)
+		 ((zerop (logandc2 tag2 tag1)) ; t2 <= t1
+		  t2)
+		 (t
+		  `(AND ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
+	   t2)
+	  ((eq tag2 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
+	   t1)
+	  ((null tag1)
+           (setf c::*compiler-break-enable* t)
+           ;(error "foo")
+	   (cmpnote "Unknown type ~S. Assuming it is T." t1)
+	   t2)
+	  (t
+           (setf c::*compiler-break-enable* t)
+           ;(error "foo")
+	   (cmpnote "Unknown type ~S. Assuming it is T." t2)
+	   t1))))
+
+(defun-equal-cached values-type-primary-type (type)
+  (when (and (consp type) (eq (first type) 'VALUES))
+    (let ((subtype (second type)))
+      (when (or (eq subtype '&optional) (eq subtype '&rest))
+        (setf type (cddr type))
+        (when (or (null type)
+                  (eq (setf subtype (first type)) '&optional)
+                  (eq subtype '&rest))
+          (cmperr "Syntax error in type expression ~S" type))
+        ;; An &optional or &rest output value might be missing
+        ;; If this is the case, the the value will be NIL.
+        (setf subtype (type-or 'null subtype)))
+      (setf type subtype)))
+  type)
+
+(defun-equal-cached values-type-to-n-types (type length)
+  (if (or (atom type) (not (eql (first type) 'values)))
+      (list* type (make-list (1- length) :initial-element 'NULL))
+      (do* ((l (rest type))
+            (output '())
+            (n length (1- n)))
+           ((or (null l) (zerop n)) (nreverse output))
+        (let ((type (pop l)))
+          (case type
+            (&optional
+             (when (null l)
+               (cmperr "Syntax error in type expression ~S" type))
+             (setf type (pop l)))
+            (&rest
+             (when (null l)
+               (cmperr "Syntax error in type expression ~S" type))
+             (return-from values-type-to-n-types
+               (nreconc output (make-list n :initial-element (first l))))))
+          (push type output)))))
+
+(defun split-values-type (type)
+  (if (or (atom type) (not (eq (first type) 'VALUES)))
+      (values (list type) nil nil)
+      (let ((rest (member '&rest type))
+            (opt (member '&optional type)))
+        (values (ldiff (rest type) (or rest opt))
+                (ldiff (rest (member '&optional type)) rest)
+                (rest (member '&rest type))))))
+
+(defun-equal-cached values-type-or (t1 t2)
+  (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
+    (return-from values-type-or t2))
+  (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
+    (return-from values-type-or t1))
+  (unless t1
+    (return-from values-type-or t2))
+  (unless t2
+    (return-from values-type-or t1))
+  (multiple-value-bind (req1 opt1 rest1)
+      (split-values-type t1)
+    (multiple-value-bind (req2 opt2 rest2)
+        (split-values-type t2)
+      (let ((req '())
+            (opt '())
+            (rest '()))
+        (loop for t1 in req1
+           do (cond (req2
+                     (push (type-or t1 (pop req2)) req))
+                    (opt2
+                     (push (type-or t1 (pop opt2)) opt))
+                    (rest2
+                     (push (type-or t1 (first rest2)) opt))
+                    (t
+                     (push t1 opt))))
+        (loop for t1 in opt1
+           do (cond (req2
+                     (push (type-or t1 (pop req2)) opt))
+                    (opt2
+                     (push (type-or t1 (pop opt2)) opt))
+                    (rest2
+                     (push (type-or t1 (first rest2)) opt))
+                    (t
+                     (push t1 opt))))
+        (let ((t1 (if rest1 (first rest1) t)))
+          (loop for t2 in req2
+             do (push (type-or t1 t2) opt))
+          (loop for t2 in opt2
+             do (push (type-or t1 t2) opt))
+          (if rest2
+              (setf rest (list (type-or t1 (first rest2))))
+              (setf rest rest1)))
+        `(VALUES ,@(nreverse req)
+                 ,@(and opt (cons '&optional (nreverse opt)))
+                 ,@(and rest (cons '&optional rest)))))))
+
+(defun-equal-cached values-type-and (t1 t2)
+  (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
+    (return-from values-type-and t1))
+  (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
+    (return-from values-type-and t2))
+  (when (or (null t1) (null t2))
+    (return-from values-type-and nil))
+  (multiple-value-bind (req1 opt1 rest1)
+      (split-values-type t1)
+    (multiple-value-bind (req2 opt2 rest2)
+        (split-values-type t2)
+      (let ((req '())
+            (opt '())
+            (rest '()))
+        (loop for t1 in req1
+           do (cond (req2 (push (type-and t1 (pop req2)) req))
+                    (opt2 (push (type-and t1 (pop opt2)) req))
+                    (rest2 (push (type-and t1 (first rest2)) req))
+                    (t (setf opt1 nil rest1 nil) (return))))
+        (loop for t1 in opt1
+           do (cond (req2 (push (type-and t1 (pop req2)) req))
+                    (opt2 (push (type-and t1 (pop opt2)) opt))
+                    (rest2 (push (type-and t1 (first rest2)) opt))
+                    (t (setf opt1 nil rest1 nil) (return))))
+        (when rest
+          (let ((t1 (first rest)))
+            (loop for t2 in req2
+               do (push (type-and t1 t2) req))
+            (loop for t2 in opt2
+               do (push (type-and t1 t2) opt))
+            (when rest2
+              (setf rest (list (type-and t1 (first rest2)))))))
+        `(VALUES ,@(nreverse req)
+                 ,@(and opt (cons '&optional (nreverse opt)))
+                 ,@(and rest (cons '&optional rest)))))))
+
+(defun-equal-cached type-or (t1 t2)
+  ;; FIXME! Should we allow "*" as type name???
+  (when (or (eq t1 t2) (eq t2 '*))
+    (return-from type-or t1))
+  (when (eq t1 '*)
+    (return-from type-or t2))
+  (let* ((si::*highest-type-tag* si::*highest-type-tag*)
+	 (si::*save-types-database* t)
+	 (si::*member-types* si::*member-types*)
+	 (si::*elementary-types* si::*elementary-types*)
+	 (tag1 (si::safe-canonical-type t1))
+	 (tag2 (si::safe-canonical-type t2)))
+    (cond ((and (numberp tag1) (numberp tag2))
+	   (setf tag1 (si::safe-canonical-type t1)
+		 tag2 (si::safe-canonical-type t2))
+	   (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
+		  t2)
+		 ((zerop (logandc2 tag2 tag1)) ; t2 <= t1
+		  t1)
+		 (t
+		  `(OR ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
+	   T)
+	  ((eq tag2 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
+	   T)
+	  ((null tag1)
+	   (cmpnote "Unknown type ~S" t1)
+	   T)
+	  (t
+	   (cmpnote "Unknown type ~S" t2)
+	   T))))
+
+(defun type>= (type1 type2)
+  (subtypep type2 type1))
+
src/new-cmp/cmpc-wt.lsp to src/cmp/cmpform.lsp
--- a/src/new-cmp/cmpc-wt.lsp
+++ b/src/cmp/cmpform.lsp
@@ -1,7 +1,6 @@
 ;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 ;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2009, Juan Jose Garcia-Ripoll
 ;;;;
 ;;;;    This program is free software; you can redistribute it and/or
 ;;;;    modify it under the terms of the GNU Library General Public
@@ -9,95 +8,82 @@
 ;;;;    version 2 of the License, or (at your option) any later version.
 ;;;;
 ;;;;    See file '../Copyright' for full details.
+;;;;
+;;;; CMPFORM -- Internal representation of Lisp forms
+;;;;
 
-;;;; CMPWT -- Routines for writing code to C files.
+(in-package "COMPILER")
 
-(in-package "C-BACKEND")
+(defun print-c1form (form stream)
+  (format stream "#<form ~A ~X>" (c1form-name form) (ext::pointer form)))
 
-(defvar *wt-string-size* 0)
+(defun make-c1form (name subform &rest args)
+  (let ((form (do-make-c1form :name name :args args
+			      :type (info-type subform)
+			      :sp-change (info-sp-change subform)
+			      :volatile (info-volatile subform)
+                              :form *current-form*
+                              :toplevel-form *current-toplevel-form*
+                              :file *compile-file-truename*
+                              :file-position *compile-file-position*)))
+    (c1form-add-info form args)
+    form))
 
-;;; from cmpwt.lsp
-(defmacro wt (&rest forms &aux (fl nil))
-  (dolist (form forms `(progn ,@(nreverse (cons nil fl))))
-    (if (stringp form)
-        (push `(princ ,form *compiler-output1*) fl)
-        (push `(wt1 ,form) fl))))
+(defun make-c1form* (name &rest args)
+  (let ((info-args '())
+	(form-args '()))
+    (do ((l args (cdr l)))
+	((endp l))
+      (let ((key (first l)))
+	(cond ((not (keywordp key))
+	       (baboon))
+	      ((eq key ':args)
+	       (setf form-args (rest l))
+	       (return))
+	      (t
+	       (setf info-args (list* key (second l) info-args)
+		     l (cdr l))))))
+    (let ((form (apply #'do-make-c1form :name name :args form-args
+                       :form *current-form*
+                       :toplevel-form *current-toplevel-form*
+                       :file *compile-file-truename*
+                       :file-position *compile-file-position*
+		       info-args)))
+      (c1form-add-info form form-args)
+      form)))
 
-(defmacro wt-h (&rest forms &aux (fl nil))
-  (dolist (form forms `(progn ,@(nreverse (cons nil fl))))
-    (if (stringp form)
-      (push `(princ ,form *compiler-output2*) fl)
-      (push `(wt-h1 ,form) fl))))
+(defun c1form-add-info (form dependents)
+  (dolist (subform dependents form)
+    (cond ((c1form-p subform)
+	   (when (info-sp-change subform)
+	     (setf (info-sp-change form) t))
+	   (setf (c1form-parent subform) form))
+	  ((consp subform)
+	   (c1form-add-info form subform)))))
 
-(defmacro wt-nl-h (&rest forms)
-  `(progn (terpri *compiler-output2*) (wt-h ,@forms)))
+(defun copy-c1form (form)
+  (copy-structure form))
 
-(defmacro princ-h (form) `(princ ,form *compiler-output2*))
+(defmacro c1form-arg (nth form)
+  (case nth
+    (0 `(first (c1form-args ,form)))
+    (1 `(second (c1form-args ,form)))
+    (otherwise `(nth ,nth (c1form-args ,form)))))
 
-(defmacro wt-nl (&rest forms)
-  `(wt #\Newline #\Tab ,@forms))
+(defun c1form-volatile* (form)
+  (if (c1form-volatile form) "volatile " ""))
 
-(defmacro wt-nl1 (&rest forms)
-  `(wt #\Newline ,@forms))
+(defun c1form-primary-type (form)
+  (values-type-primary-type (c1form-type form)))
 
-(defmacro wt-go (label)
-  `(wt "goto L" ,label ";"))
+#-new-cmp
+(defun location-primary-type (form)
+  (c1form-primary-type form))
 
-(defun wt-label (label)
-  (wt-nl1 "L" label ":;"))
-
-(defun wt-filtered-comment (text stream single-line)
-  (declare (string text))
-  (if single-line
-      (progn
-	(fresh-line stream)
-	(princ "/*	" stream))
-      (format stream "~50T/*  "))
-  (let* ((l (1- (length text))))
-    (declare (fixnum l))
-    (dotimes (n l)
-      (let ((c (schar text n)))
-	(princ c stream)
-	(when (and (char= c #\*) (char= (schar text (1+ n)) #\/))
-	  (princ #\\ stream))))
-    (princ (schar text l) stream))
-  (format stream "~70T*/")
-  )
-
-(defun do-wt-comment (message-or-format args single-line-p)
-  (unless (and (symbolp message-or-format) (not (symbol-package message-or-format)))
-    (wt-filtered-comment (if (stringp message-or-format)
-                             (if args
-                                 (apply #'format nil message-or-format args)
-                                 message-or-format)
-                             (princ-to-string message-or-format))
-                         *compiler-output1*
-                         single-line-p)))
-
-(defun wt-comment (message &rest extra)
-  (do-wt-comment message extra nil))
-
-(defun wt-comment-nl (message &rest extra)
-  (do-wt-comment message extra t))
-
-(defun wt1 (form)
-  (typecase form
-    ((or STRING INTEGER CHARACTER)
-     (princ form *compiler-output1*))
-    ((or DOUBLE-FLOAT SINGLE-FLOAT)
-     (format *compiler-output1* "~10,,,,,,'eG" form))
-    (LONG-FLOAT
-     (format *compiler-output1* "~,,,,,,'eEl" form))
-    (VAR (wt-var form))
-    (t (wt-loc form)))
-  nil)
-
-(defun wt-h1 (form)
-  (if (consp form)
-      (let ((fun (get-sysprop (car form) 'wt-loc)))
-	(if fun
-	    (let ((*compiler-output1* *compiler-output2*))
-	      (apply fun (cdr form)))
-	    (cmperr "The location ~s is undefined." form)))
-      (princ form *compiler-output2*))
-  nil)
+(defun find-node-in-list (home-node list)
+  (flet ((parent-node-p (node presumed-child)
+	   (loop
+	    (cond ((null presumed-child) (return nil))
+		  ((eq node presumed-child) (return t))
+		  (t (setf presumed-child (c1form-parent presumed-child)))))))
+    (member home-node list :test #'parent-node-p)))
src/new-cmp/cmpdefs.lsp to src/cmp/cmpenv-declaim.lsp
--- a/src/new-cmp/cmpdefs.lsp
+++ b/src/cmp/cmpenv-declaim.lsp
@@ -1,6 +1,8 @@
 ;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 ;;;;
-;;;;  Copyright (c) 2009, Juan Jose Garcia-Ripoll
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
+;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;
 ;;;;    This program is free software; you can redistribute it and/or
 ;;;;    modify it under the terms of the GNU Library General Public
@@ -9,61 +11,42 @@
 ;;;;
 ;;;;    See file '../Copyright' for full details.
 ;;;;
-;;;;  CMPDEFS -- Definitions created at compile / configuration time
+;;;; CMPENV-DECLAIM -- Proclamations local to the current file
+;;;;
+;;;; One implementation of DECLAIM that uses the compiler environment
+;;;; providing a "base" set of entries that all other environments
+;;;; stem from.
+;;;;
+ 
+(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
 
-(in-package "C")
+(defun process-declaim-args (args)
+  (flet ((add-variables (env types specials)
+           (loop for name in specials
+              unless (assoc name types)
+              do (let ((v (c1make-global-variable name :kind 'special)))
+                   (setf env (cmp-env-register-var v env))))
+           (loop for (name . type) in types
+              for specialp = (or (sys:specialp name) (member name specials))
+              for kind = (if specialp 'SPECIAL 'GLOBAL)
+              for v = (c1make-global-variable name :type type :kind kind)
+              do (setf env (cmp-env-register-var v env)))
+           env))
+    (multiple-value-bind (body specials types ignored others doc all)
+        (c1body `((DECLARE ,@args)) nil)
+      (when ignored
+        (cmpwarn "IGNORE/IGNORABLE declarations in DECLAIM are ignored"))
+      (reduce #'add-one-declaration others
+              :initial-value (add-variables *cmp-env* types specials))
+      (reduce #'add-one-declaration others
+              :initial-value (add-variables *cmp-env-root* types specials)))))
 
-;;; This is copied into each .h file generated, EXCEPT for system-p calls.
-;;; The constant string *include-string* is the content of file "ecl.h".
-;;; Here we use just a placeholder: it will be replaced with sed.
-(defvar *cmpinclude* "<ecl/ecl-cmp.h>")
-
-;;;
-;;; Compiler program and flags.
-;;;
-
-(defvar *cc* "@ECL_CC@"
-"This variable controls how the C compiler is invoked by ECL.
-The default value is \"cc -I. -I/usr/local/include/\".
-The second -I option names the directory where the file ECL.h has been installed.
-One can set the variable appropriately adding for instance flags which the 
-C compiler may need to exploit special hardware features (e.g. a floating point
-coprocessor).")
-
-(defvar *ld* "@ECL_CC@"
-"This variable controls the linker which is used by ECL.")
-
-(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@")
-
-(defvar *cc-optimize* #-msvc "-O"
-                      #+msvc "@CFLAGS_OPTIMIZE@")
-
-(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@?"
-                    #+msvc "~A -Fe~S~* ~{~S ~} ~@?")
-
-(defvar *cc-format* #-msvc "~A ~A ~:[~*~;~A~] \"-I~A\" -w -c \"~A\" -o \"~A\""
-                    #+msvc "~A ~A ~:[~*~;~A~] -I\"~A\" -w -c \"~A\" -Fo\"~A\"")
-
-#-dlopen
-(defvar *ld-flags* "@LDFLAGS@ -lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@")
-#+dlopen
-(defvar *ld-flags* #-msvc "@LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
-                   #+msvc "@LDFLAGS@ ecl.lib @CLIBS@")
-#+dlopen
-(defvar *ld-shared-flags* #-msvc "@SHARED_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
-                          #+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@")
-#+dlopen
-(defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
-                          #+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@")
-
-(defvar +shared-library-prefix+ "@SHAREDPREFIX@")
-(defvar +shared-library-extension+ "@SHAREDEXT@")
-(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
-(defvar +static-library-prefix+ "@LIBPREFIX@")
-(defvar +static-library-extension+ "@LIBEXT@")
-(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
-(defvar +object-file-extension+ "@OBJEXT@")
-(defvar +executable-file-format+ "~a@EXEEXT@")
-
-(defvar *ecl-include-directory* @includedir\@)
-(defvar *ecl-library-directory* @libdir\@)
+(defmacro declaim (&rest declarations)
+  `(progn
+     (ext:with-backend
+       :c/c++ (eval-when (:compile-toplevel)
+                (c::process-declaim-args ',declarations))
+       :bytecodes (eval-when (:compile-toplevel)
+                    (proclaim ',declarations)))
+     (eval-when (:load-toplevel :execute)
+       (mapc 'proclaim ',declarations))))
src/new-cmp/cmpenv.lsp to src/cmp/cmpglobals.lsp
--- a/src/new-cmp/cmpenv.lsp
+++ b/src/cmp/cmpglobals.lsp
@@ -1,7 +1,6 @@
 ;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 ;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;
 ;;;;    This program is free software; you can redistribute it and/or
 ;;;;    modify it under the terms of the GNU Library General Public
@@ -9,672 +8,341 @@
 ;;;;    version 2 of the License, or (at your option) any later version.
 ;;;;
 ;;;;    See file '../Copyright' for full details.
-
-;;;; CMPENV  Environments of the Compiler.
-
-(in-package "C-ENV")
-
-(defun function-arg-types (arg-types &aux (types nil))
-  (do ((al arg-types (cdr al)))
-      ((or (endp al)
-           (member (car al) '(&optional &rest &key)))
-       (nreverse types))
-      (declare (object al))
-      (push (c-types:type-filter (car al)) types)))
-
-(defun proper-list-p (x &optional test)
-  (and (listp x)
-       (handler-case (list-length x) (type-error (c) nil))
-       (or (null test) (every test x))))
-
-;;; The valid return type declaration is:
-;;;	(( VALUES {type}* )) or ( {type}* ).
-
-(defun function-return-type (return-types)
-  (cond ((endp return-types) t)
-        ((and (consp (car return-types))
-              (eq (caar return-types) 'VALUES))
-         (cond ((not (endp (cdr return-types)))
-                (warn "The function return types ~s is illegal." return-types)
-                t)
-               ((or (endp (cdar return-types))
-                    (member (cadar return-types) '(&optional &rest &key)))
-                t)
-               (t (c-types:type-filter (cadar return-types)))))
-        (t (c-types:type-filter (car return-types)))))
-
-(defun add-function-proclamation (fname decl)
-  (if (si:valid-function-name-p fname)
-      (let* ((arg-types '*)
-	     (return-types '*)
-	     (l decl))
-	(cond ((null l))
-	      ((consp l)
-	       (setf arg-types (pop l)))
-	      (t (warn "The function proclamation ~s ~s is not valid."
-		       fname decl)))
-	(cond ((null l))
-	      ((and (consp l) (null (rest l)))
-	       (setf return-types (function-return-type l)))
-	      (t (warn "The function proclamation ~s ~s is not valid."
-		       fname decl)))
-	(if (eq arg-types '*)
-	    (rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
-	    (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
-	(if (eq return-types '*)
-	    (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
-	    (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
-      (warn "The function proclamation ~s ~s is not valid." fname decl)))
-
-(defun add-function-declaration (fname arg-types return-types env)
-  (if (si::valid-function-name-p fname)
-      (cmp-env-register-ftype fname (list arg-types return-types) env)
-      (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))
-  env)
-
-(defun get-arg-types (fname &optional (env *cmp-env*))
-  (let ((x (cmp-env-search-ftype fname env)))
-    (if x
-        (values (first x) t)
-        (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
-
-(defun get-return-type (fname &optional (env *cmp-env*))
-  (let ((x (cmp-env-search-ftype fname env)))
-    (if x
-	(values (second x) t)
-	(sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
-
-(defun get-local-arg-types (fun &optional (env *cmp-env*))
-  (let ((x (cmp-env-search-ftype (fun-name fun))))
-    (if x
-        (values (first x) t)
-        (values nil nil))))
-
-(defun get-local-return-type (fun &optional (env *cmp-env*))
-  (let ((x (cmp-env-search-ftype (fun-name fun))))
-    (if x
-        (values (second x) t)
-        (values nil nil))))
-
-(defun get-proclaimed-narg (fun &optional (env *cmp-env*))
-  (multiple-value-bind (arg-list found)
-      (get-arg-types fun env)
-    (if found
-	(loop for type in arg-list
-	   with minarg = 0
-	   and maxarg = 0
-	   and in-optionals = nil
-	   do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
-		     (return (values minarg call-arguments-limit)))
-		    ((eq type '&optional)
-		     (setf in-optionals t maxarg minarg))
-		    (in-optionals
-		     (incf maxarg))
-		    (t
-		     (incf minarg)
-		     (incf maxarg)))
-	   finally (return (values minarg maxarg found)))
-	(values 0 call-arguments-limit found))))
-
-;;; Proclamation and declaration handling.
-
-(defun inline-possible (fname &optional (env *cmp-env*))
-  (not (or ; (compiler-<push-events)
-	;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
-        (let ((x (cmp-env-search-declaration 'notinline env)))
-          (and x (member fname x :test #'same-fname-p)))
-	(member fname *notinline* :test #'same-fname-p)
-	(sys:get-sysprop fname 'CMP-NOTINLINE))))
-
-#-:CCL
-(defun proclaim (decl &aux decl-name)
-  (unless (listp decl)
-	  (error "The proclamation specification ~s is not a list" decl))
-  (case (setf decl-name (car decl))
-    (SPECIAL
-     (dolist (var (cdr decl))
-       (if (symbolp var)
-           (sys:*make-special var)
-           (error "Syntax error in proclamation ~s" decl))))
-    (OPTIMIZE
-     (dolist (x (cdr decl))
-       (when (symbolp x) (setq x (list x 3)))
-       (if (or (not (consp x))
-               (not (consp (cdr x)))
-               (not (numberp (second x)))
-               (not (<= 0 (second x) 3)))
-           (warn "The OPTIMIZE proclamation ~s is illegal." x)
-           (case (car x)
-		 (DEBUG (setq *debug* (second x)))
-                 (SAFETY (setq *safety* (second x)))
-                 (SPACE (setq *space* (second x)))
-                 (SPEED (setq *speed* (second x)))
-                 (COMPILATION-SPEED (setq *speed* (- 3 (second x))))
-                 (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
-    (TYPE
-     (if (consp (cdr decl))
-         (proclaim-var (second decl) (cddr decl))
-         (error "Syntax error in proclamation ~s" decl)))
-    (FTYPE
-     (if (atom (rest decl))
-	 (error "Syntax error in proclamation ~a" decl)
-	 (multiple-value-bind (type-name args)
-	     (si::normalize-type (second decl))
-	   (if (eq type-name 'FUNCTION)
-	       (dolist (v (cddr decl))
-		 (add-function-proclamation v args))
-	       (error "In an FTYPE proclamation, found ~A which is not a function type."
-		      (second decl))))))
-    (INLINE
-     (dolist (fun (cdr decl))
-       (if (si::valid-function-name-p fun)
-	   (sys:rem-sysprop fun 'CMP-NOTINLINE)
-	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
-    (NOTINLINE
-     (dolist (fun (cdr decl))
-       (if (si::valid-function-name-p fun)
-	   (sys:put-sysprop fun 'CMP-NOTINLINE t)
-	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
-    ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
-     ;; FIXME! IGNORED!
-     (dolist (var (cdr decl))
-       (unless (si::valid-function-name-p var)
-	 (error "Not a valid function name ~s in ~s proclamation" fun decl-name))))
-    (DECLARATION
-     (validate-alien-declaration (rest decl) #'error)
-     (setf si::*alien-declarations*
-           (nconc (copy-list (rest decl)) si::*alien-declarations*)))
-    (SI::C-EXPORT-FNAME
-     (dolist (x (cdr decl))
-       (cond ((symbolp x)
-	      (multiple-value-bind (found c-name)
-		  (si::mangle-name x t)
-		(if found
-		    (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
-		    (sys:put-sysprop x 'Lfun c-name))))
-	     ((consp x)
-	      (destructuring-bind (c-name lisp-name) x
-		(if (si::mangle-name lisp-name)
-		    (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
-		    (sys:put-sysprop lisp-name 'Lfun c-name))))
-	     (t
-	      (error "Syntax error in proclamation ~s" decl)))))
-    ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION
-      COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
-      LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
-      READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR
-      SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING
-      SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
-     (proclaim-var decl-name (cdr decl)))
-    (otherwise
-     (cond ((multiple-value-bind (ok type)
-		(c-types:valid-type-specifier decl-name)
-	      (when ok
-		(proclaim-var type (rest decl))
-		t)))
-	   ((let ((proclaimer (sys:get-sysprop (car decl) :proclaim)))
-	      (when (functionp proclaimer)
-		(mapc proclaimer (rest decl))
-		t)))
-	   ((alien-declaration-p (first decl)))
-	   (t
-	    (warn "The declaration specifier ~s is unknown." decl-name))))))
-
-(defun type-name-p (name)
-  (or (sys:get-sysprop name 'SI::DEFTYPE-DEFINITION)
-      (find-class name nil)
-      (sys:get-sysprop name 'SI::STRUCTURE-TYPE)))
-
-(defun validate-alien-declaration (names-list error)
-  (declare (si::c-local))
-  (dolist (new-declaration names-list)
-    (unless (symbolp new-declaration)
-      (funcall error "The declaration ~s is not a symbol" new-declaration))
-    (when (type-name-p new-declaration)
-      (funcall error "Symbol ~S cannot be both the name of a type and of a declaration"
-               new-declaration))))
-
-(defun proclaim-var (type vl)
-  (setq type (c-types:type-filter type))
-  (dolist (var vl)
-    (if (symbolp var)
-	(let* ((type1 (sys:get-sysprop var 'CMP-TYPE))
-               (v (find var *undefined-vars* :key #'var-name))
-               (merged (if type1 (type-and type1 type) type)))
-	  (unless merged
-	    (warn
-	     "Proclamation for variable ~A of type~&~4T~A~&is incompatible with previous declaration~&~4~T~A"
-	     var type type1)
-	    (setq merged T))
-	  (sys:put-sysprop var 'CMP-TYPE merged)
-	  (when v (setf (var-type v) merged)))
-	(warn "The variable name ~s is not a symbol." var))))
-
-(defun c1body (body doc-p &aux
-	            (all-declarations nil)
-		    (ss nil)		; special vars
-		    (is nil)		; ignored vars
-		    (ts nil)		; typed vars (var . type)
-		    (others nil)	; all other vars
-	            doc form)
-  (loop
-    (when (endp body) (return))
-    (setq form (cmp-macroexpand (car body)))
-    (cond
-     ((stringp form)
-      (when (or (null doc-p) (endp (cdr body)) doc) (return))
-      (setq doc form))
-     ((and (consp form) (eq (car form) 'DECLARE))
-      (push form all-declarations)
-      (dolist (decl (cdr form))
-        (cmpassert (and (proper-list-p decl) (symbolp (first decl)))
-		   "Syntax error in declaration ~s" form)
-	(let* ((decl-name (first decl))
-	       (decl-args (rest decl)))
-	  (flet ((declare-variables (type var-list)
-		   (cmpassert (proper-list-p var-list #'symbolp)
-			      "Syntax error in declaration ~s" decl)
-		   (when type
-		     (dolist (var var-list)
-		       (push (cons var type) ts)))))
-	    (case decl-name
-	      (SPECIAL
-	       (cmpassert (proper-list-p decl-args #'symbolp)
-			  "Syntax error in declaration ~s" decl)
-	       (setf ss (append decl-args ss)))
-	      (IGNORE
-	       (cmpassert (proper-list-p decl-args #'symbolp)
-			  "Syntax error in declaration ~s" decl)
-	       (setf is (append decl-args is)))
-	      (TYPE
-	       (cmpassert decl-args "Syntax error in declaration ~s" decl)
-	       (declare-variables (first decl-args) (rest decl-args)))
-	      (OBJECT
-	       (declare-variables 'OBJECT decl-args))
-	      ;; read-only variable treatment. obsolete!
-	      (:READ-ONLY
-	       (push decl others))
-	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
-		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
-                POLICY-DEBUG-IHS-FRAME)
-	       (push decl others))
-	      (otherwise
-	       (multiple-value-bind (ok type)
-                   (c-types:valid-type-specifier decl-name)
-                 (cmpassert ok "The declaration specifier ~s is unknown." decl-name)
-                 (declare-variables type decl-args)))
-	      )))))
-     (t (return)))
-    (pop body))
-  (values body ss ts is others doc all-declarations))
-
-(defun default-optimization (optimization)
-  (ecase optimization
-    (speed *speed*)
-    (safety *safety*)
-    (space *space*)
-    (debug *debug*)))
-
-(defun search-optimization-quality (declarations what)
-  (dolist (i (reverse declarations)
-	   (default-optimization what))
-    (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
-               (eq what 'debug))
-      (return 2))      
-    (when (and (consp i) (eq (first i) 'optimize))
-      (dolist (j (rest i))
-	(cond ((consp j)
-	       (when (eq (first j) what)
-		 (return-from search-optimization-quality (second j))))
-	      ((eq j what)
-	       (return-from search-optimization-quality 3)))))))
-
-(defun compute-optimizations (arguments env)
-  (let ((optimizations (cmp-env-all-optimizations env)))
-    (dolist (x arguments)
-      (when (symbolp x) (setq x (list x 3)))
-      (unless optimizations
-        (setq optimizations (cmp-env-all-optimizations)))
-      (if (or (not (consp x))
-              (not (consp (cdr x)))
-              (not (numberp (second x)))
-              (not (<= 0 (second x) 3)))
-          (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
-          (let ((value (second x)))
-            (case (car x)
-              (DEBUG (setf (first optimizations) value))
-              (SAFETY (setf (second optimizations) value))
-              (SPACE (setf (third optimizations) value))
-              (SPEED (setf (fourth optimizations) value))
-              (COMPILATION-SPEED)
-              (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))
-    optimizations))
-
-(defun add-declarations (decls &optional (env *cmp-env*))
-  (dolist (decl decls)
-    (case (car decl)
-      (OPTIMIZE
-       (let ((optimizations (compute-optimizations (rest decl) env)))
-         (setf env (cmp-env-add-declaration 'optimize optimizations))))
-      (POLICY-DEBUG-IHS-FRAME
-       (setf env (cmp-env-add-declaration 'optimize (compute-optimizations '(debug 2) env))))
-      (FTYPE
-       (if (atom (rest decl))
-	   (cmpwarn "Syntax error in declaration ~a" decl)
-	   (multiple-value-bind (type-name args)
-	       (si::normalize-type (second decl))
-	     (if (eq type-name 'FUNCTION)
-		 (dolist (v (cddr decl))
-                   (setf env (add-function-declaration v (first args) (rest args) env)))
-		 (cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
-			  (second decl))))))
-      (INLINE
-       (let* ((x (copy-list (cmp-env-search-declaration 'notinline)))
-              (names (rest decl)))
-         (dolist (fun names)
-           (unless (si::valid-function-name-p fun)
-             (cmperr "Not a valid function name ~s in declaration ~s" fun decl))
-           (setf x (delete fun x :test #'same-fname-p)))
-         (setf env (cmp-env-add-declaration 'notinline x))))
-      (NOTINLINE
-       (let* ((x (cmp-env-search-declaration 'notinline))
-              (names (rest decl)))
-         (dolist (fun names)
-           (if (si::valid-function-name-p fun)
-               (push fun x)
-               (cmperr "Not a valid function name ~s in declaration ~s" fun decl)))
-         (setf env (cmp-env-add-declaration 'notinline x))))
-      (DECLARATION
-       (validate-alien-declaration (rest decl) #'cmperr)
-       (cmp-env-extend-declarations 'alien (rest decl)))
-      ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE))
-      ((DYNAMIC-EXTENT IGNORABLE)
-       ;; FIXME! SOME ARE IGNORED!
-       )
-      (:READ-ONLY)
-      (otherwise
-       (unless (alien-declaration-p (first decl))
-	 (cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
-  env)
-
-(defun check-vdecl (vnames ts is)
-  (dolist (x ts)
-    (unless (member (car x) vnames)
-      (cmpwarn "Type declaration was found for not bound variable ~s."
-               (car x))))
-  (dolist (x is)
-    (unless (member x vnames)
-      (cmpwarn "Ignore declaration was found for not bound variable ~s." x))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; COMPILER ENVIRONMENT
-;;;
-
-(defmacro cmp-env-new ()
-  '(cons nil nil))
-
-(defun cmp-env-copy (&optional (env *cmp-env*))
-  (cons (car env) (cdr env)))
-
-(defmacro cmp-env-variables (&optional (env '*cmp-env*))
-  `(car ,env))
-
-(defmacro cmp-env-functions (&optional (env '*cmp-env*))
-  `(cdr ,env))
-
-(defun cmp-env-cleanups (env)
-  (loop with specials = '()
-	with end = (cmp-env-variables env)
-	with cleanup-forms = '()
-	with aux
-	for records-list on (cmp-env-variables *cmp-env*)
-	until (eq records-list end)
-	do (let ((record (first records-list)))
-	     (cond ((atom record))
-		   ((and (symbolp (first record))
-			 (eq (second record) :special))
-		    (push (fourth record) specials))
-		   ((eq (first record) :cleanup)
-		    (push (second record) cleanup-forms))))
-	finally (progn
-		  (unless (eq records-list end)
-		    (error "Inconsistency in environment."))
-		  (return (values specials
-                                  (apply #'nconc (mapcar #'copy-list cleanup-forms)))))))
-
-(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t))
-  (push (list (var-name var)
-	      (if (member (var-kind var) '(special global))
-		  :special
-		  t)
-	      boundp
-	      var)
-	(cmp-env-variables env))
-  env)
-
-(defun cmp-env-declare-special (name &optional (env *cmp-env*))
-  (cmp-env-register-var (c::c1make-global-variable name :warn nil :kind 'SPECIAL)
-			env nil)
-  env)
-
-(defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*))
-  (push (list* :declare type arguments) 
-        (cmp-env-variables env))
-  env)
-
-(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*))
-  (let ((x (cmp-env-search-declaration type)))
-    (cmp-env-add-declaration type (append arguments x) env)
-    env))
-
-(defun cmp-env-register-function (fun &optional (env *cmp-env*))
-  (push (list (fun-name fun) 'function fun)
-	(cmp-env-functions env))
-  env)
-
-(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
-  (push (list name 'si::macro function)
-	(cmp-env-functions env))
-  env)
-
-(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*))
-  (push (list* :declare name declaration)
-        (cmp-env-functions env))
-  env)
-
-(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
-  (push (list name 'si::symbol-macro #'(lambda (whole env) form))
-	(cmp-env-variables env))
-  env)
-
-(defun cmp-env-register-block (blk &optional (env *cmp-env*))
-  (push (list :block (blk-name blk) blk)
-	(cmp-env-variables env))
-  env)
-
-(defun cmp-env-register-tag (name tag &optional (env *cmp-env*))
-  (push (list :tag (list name) tag)
-	(cmp-env-variables env))
-  env)
-
-(defun cmp-env-register-cleanup (form &optional (env *cmp-env*))
-  (push (list :cleanup (copy-list form)) (cmp-env-variables env))
-  env)
-
-(defun cmp-env-search-function (name &optional (env *cmp-env*))
-  (let ((ccb nil)
-	(clb nil)
-	(unw nil)
-	(found nil))
-    (dolist (record (cmp-env-functions env))
-      (cond ((eq record 'CB)
-	     (setf ccbb t))
-	    ((eq record 'LB)
-	     (setf clb t))
-	    ((eq record 'UNWIND-PROTECT)
-	     (setf unw t))
-	    ((atom record)
-	     (baboon))
-	    ;; We have to use EQUAL because the name can be a list (SETF whatever)
-	    ((equal (first record) name)
-	     (setf found (first (last record)))
-	     (return))))
-    (values found ccb clb unw)))
-
-(defun cmp-env-search-variables (type name env)
-  (let ((ccb nil)
-	(clb nil)
-	(unw nil)
-	(found nil))
-    (dolist (record (cmp-env-variables env))
-      (cond ((eq record 'CB)
-	     (setf ccb t))
-	    ((eq record 'LB)
-	     (setf clb t))
-	    ((eq record 'UNWIND-PROTECT)
-	     (setf unw t))
-	    ((atom record)
-	     (baboon))
-	    ((not (eq (first record) type)))
-	    ((eq type :block)
-	     (when (eq name (second record))
-	       (setf found record)
-	       (return)))
-	    ((eq type :tag)
-	     (when (member name (second record) :test #'eql)
-	       (setf found record)
-	       (return)))
-	    ((eq (second record) 'si::symbol-macro)
-	     (when (eq name 'si::symbol-macro)
-	       (setf found record))
-	     (return))
-	    (t
-	     (setf found record)
-	     (return))))
-    (values (first (last found)) ccb clb unw)))
-
-(defun cmp-env-search-block (name &optional (env *cmp-env*))
-  (cmp-env-search-variables :block name env))
-
-(defun cmp-env-search-tag (name &optional (env *cmp-env*))
-  (cmp-env-search-variables :tag name env))
-
-(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*))
-  (cmp-env-search-variables name 'si::symbol-macro env))
-
-(defun cmp-env-search-var (name &optional (env *cmp-env*))
-  (cmp-env-search-variables name t env))
-
-(defun cmp-env-search-macro (name &optional (env *cmp-env*))
-  (let ((f (cmp-env-search-function name env)))
-    (if (functionp f) f nil)))
-
-(defun cmp-env-search-ftype (name &optional (env *cmp-env*))
-  (dolist (i env nil)
-    (when (and (consp i)
-               (eq (pop i) :declare)
-               (same-fname-p (pop i) name))
-      (return i))))
-
-(defun cmp-env-mark (mark &optional (env *cmp-env*))
-  (cons (cons mark (car env))
-	(cons mark (cdr env))))
-
-(defun cmp-env-new-variables (new-env old-env)
-  (loop for i in (ldiff (cmp-env-variables *cmp-env*)
-			(cmp-env-variables old-env))
-	when (and (consp i) (var-p (fourth i)))
-	collect (fourth i)))
-
-(defun cmp-env-search-declaration (kind &optional (env *cmp-env*))
-  (loop for i in (car env)
-     when (and (consp i)
-               (eq (first i) :declare)
-               (eq (second i) kind))
-     return (cddr i)))
-
-(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
-  (or (cmp-env-search-declaration 'optimize)
-      (list *debug* *safety* *space* *speed*)))
-
-(defun cmp-env-optimization (property &optional (env *cmp-env*))
-  (let ((x (cmp-env-all-optimizations env)))
-    (case property
-      (debug (first x))
-      (safety (second x))
-      (space (third x))
-      (speed (fourth x)))))
-
-(defun policy-assume-right-type (&optional (env *cmp-env*))
-  (< (cmp-env-optimization 'safety env) 2))
-
-(defun policy-check-stack-overflow (&optional (env *cmp-env*))
-  "Do we add a stack check to every function?"
-  (>= (cmp-env-optimization 'safety env) 2))
-
-(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
-  "Do we inline access to structures and sealed classes?"
-  (or (< (cmp-env-optimization 'safety env) 2)
-      (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
-
-(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
-  "Do we assume that arguments are the right type?"
-  (> (cmp-env-optimization 'safety env) 1))
-
-(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
-  "Do we generate CHECK-TYPE forms for function arguments with type declarations?"
-  (and *automatic-check-type-in-lambda*
-       (>= (cmp-env-optimization 'safety env) 1)))
-
-(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
-  "Do we assume that type and class definitions will not change?"
-  (<= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
-  "Do we inline access to arrays?"
-  (< (cmp-env-optimization 'debug env) 2))
-
-(defun policy-open-code-accessors (&optional (env *cmp-env*))
-  "Do we inline access to object slots, including conses and arrays?"
-  (< (cmp-env-optimization 'debug env) 2))
-
-(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
-  "Check access to array bounds?"
-  (>= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-evaluate-forms (&optional (env *cmp-env*))
-  "Pre-evaluate a function that takes constant arguments?"
-  (<= (cmp-env-optimization 'debug env) 1))
-
-(defun alien-declaration-p (name)
-  (or (member name (cmp-env-search-declaration 'alien) :test #'eq)
-      (member name si:*alien-declarations*)))
-
-(defun policy-global-var-checking (&optional (env *cmp-env*))
-  "Do we have to read the value of a global variable even if it is discarded?
-Also, when reading the value of a global variable, should we ensure it is bound?"
-  (>= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-global-function-checking (&optional (env *cmp-env*))
-  "Do we have to read the binding of a global function even if it is discarded?"
-  (>= (cmp-env-optimization 'safety env) 1))
-
-(defun policy-debug-variable-bindings (&optional (env *cmp-env*))
-  "Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?"
-  ;; We can only create variable bindings when the function has an IHS frame!!!
-  (and (policy-debug-ihs-frame env)
-       (>= (cmp-env-optimization 'debug env) 3)))
-
-(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
-  "Shall we create an IHS frame so that this function shows up in backtraces?"
-  ;; Note that this is a prerequisite for registering variable bindings. Hence,
-  ;; it has to be recorded in a special variable.
-  (>= (fun-debug *current-function*) 2))
-
-(defun policy-check-nargs (&optional (env *cmp-env*))
-  (>= (cmp-env-optimization 'safety) 1))
-
-(defmacro safe-compile ()
-  `(>= (cmp-env-optimization 'safety) 2))
-
+;;;;
+;;;;  CMPGLOBALS -- Global variables and flag definitions
+;;;;
+
+(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA")
+
+;;;
+;;; VARIABLES
+;;;
+
+;;; --cmpinline.lsp--
+;;;
+;;; Empty info struct
+;;;
+#-new-cmp
+(defvar *info* (make-info))
+(defvar *inline-blocks* 0)
+;;; *inline-blocks* holds the number of C blocks opened for declaring
+;;; temporaries for intermediate results of the evaluation of inlined
+;;; function calls.
+
+;;; --cmputil.lsp--
+;;;
+;;; Variables and constants for error handling
+;;;
+(defvar *current-form* '|compiler preprocess|)
+(defvar *current-toplevel-form* '|compiler preprocess|)
+(defvar *current-c2form* nil)
+(defvar *compile-file-position* -1)
+(defvar *first-error* t)
+(defconstant *cmperr-tag* (cons nil nil))
+
+(defvar *active-handlers* nil)
+(defvar *active-protection* nil)
+(defvar *pending-actions* nil)
+
+(defvar *compiler-conditions* '()
+  "This variable determines whether conditions are printed or just accumulated.")
+
+(defvar *compile-print* nil
+  "This variable controls whether the compiler displays messages about
+each form it processes. The default value is NIL.")
+
+(defvar *compile-verbose* nil
+  "This variable controls whether the compiler should display messages about its
+progress. The default value is T.")
+
+(defvar *suppress-compiler-messages* 'compiler-debug-note
+  "A type denoting which compiler messages and conditions are _not_ displayed.")
+
+(defvar *suppress-compiler-notes* nil) ; Deprecated
+(defvar *suppress-compiler-warnings* nil) ; Deprecated
+
+(defvar *compiler-break-enable* nil)
+
+(defvar *compiler-in-use* nil)
+(defvar *compiler-input*)
+(defvar *compiler-output1*)
+(defvar *compiler-output2*)
+
+;;; --cmpcbk.lsp--
+;;;
+;;; List of callbacks to be generated
+;;;
+(defvar *callbacks* nil)
+
+;;; --cmpcall.lsp--
+;;;
+;;; Whether to use linking calls.
+;;;
+(defvar *compile-to-linking-call* t)
+(defvar *compiler-declared-globals*)
+
+;;; --cmpenv.lsp--
+;;;
+;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2))
+;;;
+(defvar *safety* 2)
+(defvar *speed* 3)
+(defvar *space* 0)
+(defvar *debug* 0)
+
+;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms.
+(defvar *automatic-check-type-in-lambda* t)
+
+;;;
+;;; Compiled code uses the following kinds of variables:
+;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
+;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
+;;; 4. lexi[j], for lexical variables in local functions
+;;; 5. CLVi, for lexical variables in closures
+
+(defvar *lcl* 0)		; number of local variables
+
+#-new-cmp
+(defvar *temp* 0)		; number of temporary variables
+#-new-cmp
+(defvar *max-temp* 0)		; maximum *temp* reached
+
+(defvar *level* 0)		; nesting level for local functions
+
+(defvar *lex* 0)		; number of lexical variables in local functions
+(defvar *max-lex* 0)		; maximum *lex* reached
+
+(defvar *env* 0)		; number of variables in current form
+(defvar *max-env* 0)		; maximum *env* in whole function
+(defvar *env-lvl* 0)		; number of levels of environments
+#-new-cmp
+(defvar *aux-closure* nil)	; stack allocated closure needed for indirect calls
+#-new-cmp
+(defvar *ihs-used-p* nil)       ; function must be registered in IHS?
+
+#-new-cmp
+(defvar *next-cmacro* 0)	; holds the last cmacro number used.
+(defvar *next-cfun* 0)		; holds the last cfun used.
+
+;;;
+;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
+;;; If possible, *tail-recursion-info* holds
+;;	( c1-lambda-form  required-arg .... required-arg ),
+;;; where each required-arg is a var-object.
+;;;
+(defvar *tail-recursion-info* nil)
+
+(defvar *allow-c-local-declaration* t)
+
+;;; --cmpexit.lsp--
+;;;
+;;; *last-label* holds the label# of the last used label.
+;;; *exit* holds an 'exit', which is
+;;	( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
+;;	RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or
+;;	RETURN-OBJECT).
+;;; *unwind-exit* holds a list consisting of:
+;;	( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
+;;	JUMP, BDS-BIND (each pushed for a single special binding), or a
+;;	LCL (which holds the bind stack pointer used to unbind).
+;;;
+(defvar *last-label* 0)
+(defvar *exit*)
+(defvar *unwind-exit*)
+
+(defvar *current-function* nil)
+
+(defvar *cmp-env* nil
+"The compiler environment consists of a pair or cons of two
+lists, one containing variable records, the other one macro and
+function recors:
+
+variable-record = (:block block-name) |
+                  (:tag ({tag-name}*)) |
+                  (:function function-name) |
+                  (var-name {:special | nil} bound-p) |
+                  (symbol si::symbol-macro macro-function) |
+                  CB | LB | UNWIND-PROTECT
+macro-record =	(function-name function) |
+                (macro-name si::macro macro-function)
+                CB | LB | UNWIND-PROTECT
+
+A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
+MACRO-FUNCTION is a function that provides us with the expansion
+for that local macro or symbol macro. BOUND-P is true when the
+variable has been bound by an enclosing form, while it is NIL if
+the variable-record corresponds just to a special declaration.
+CB, LB and UNWIND-PROTECT are only used by the C compiler and
+they denote closure, lexical environment and unwind-protect
+boundaries. Note that compared with the bytecodes compiler, these
+records contain an additional variable, block, tag or function
+object at the end.")
+
+(defvar *cmp-env-root* (cons nil nil)
+"This is the common environment shared by all toplevel forms. It can
+only be altered by DECLAIM forms and it is used to initialize the
+value of *CMP-ENV*.")
+
+;;; --cmplog.lsp--
+;;;
+;;; Destination of output of different forms. See cmploc.lsp for types
+;;; of destinations.
+;;;
+(defvar *destination*)
+
+;;; --cmpmain.lsp--
+;;;
+;;; Do we debug the compiler? Then we need files not to be deleted.
+
+(defvar *debug-compiler* nil)
+(defvar *delete-files* t)
+(defvar *files-to-be-deleted* '())
+
+(defvar *user-ld-flags* '()
+"Flags and options to be passed to the linker when building FASL, shared libraries
+and standalone programs. It is not required to surround values with quotes or use
+slashes before special characters.")
+
+(defvar *user-cc-flags* '()
+"Flags and options to be passed to the C compiler when building FASL, shared libraries
+and standalone programs. It is not required to surround values with quotes or use
+slashes before special characters.")
+
+;;;
+;;; Compiler program and flags.
+;;;
+
+;;; --cmptop.lsp--
+;;;
+(defvar *do-type-propagation* nil
+  "Flag for switching on the type propagation phase. Use with care, experimental.")
+
+(defvar *compiler-phase* nil)
+
+(defvar *volatile*)
+#-new-cmp
+(defvar *setjmps* 0)
+
+(defvar *compile-toplevel* T
+  "Holds NIL or T depending on whether we are compiling a toplevel form.")
+
+(defvar *clines-string-list* '()
+  "List of strings containing C/C++ statements which are directly inserted
+in the translated C/C++ file. Notice that it is unspecified where these
+lines are inserted, but the order is preserved")
+
+(defvar *compile-time-too* nil)
+#-new-cmp
+(defvar *not-compile-time* nil)
+
+(defvar *permanent-data* nil)		; detemines whether we use *permanent-objects*
+					; or *temporary-objects*
+(defvar *permanent-objects* nil)	; holds { ( object (VV vv-index) ) }*
+(defvar *temporary-objects* nil)	; holds { ( object (VV vv-index) ) }*
+(defvar *load-objects* nil)		; hash with association object -> vv-location
+(defvar *load-time-values* nil)		; holds { ( vv-index form ) }*,
+;;;  where each vv-index should be given an object before
+;;;  defining the current function during loading process.
+
+(defvar *use-static-constants-p* nil)   ; T/NIL flag to determine whether one may
+                                        ; generate lisp constant values as C structs
+(defvar *static-constants* nil)		; constants that can be built as C values
+                                        ; holds { ( object c-variable constant ) }*
+
+(defvar *compiler-constants* nil)	; a vector with all constants
+					; only used in COMPILE
+
+(defvar *proclaim-fixed-args* nil)	; proclaim automatically functions
+					; with fixed number of arguments.
+					; watch out for multiple values.
+
+(defvar *global-var-objects* nil)	; var objects for global/special vars
+(defvar *global-vars* nil)		; variables declared special
+(defvar *global-funs* nil)		; holds	{ fun }*
+(defvar *global-cfuns-array* nil)	; holds	{ fun }*
+(defvar *linking-calls* nil)		; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
+(defvar *local-funs* nil)		; holds { fun }*
+(defvar *top-level-forms* nil)		; holds { top-level-form }*
+(defvar *make-forms* nil)		; holds { top-level-form }*
+
+;;;
+;;;     top-level-form:
+;;;	  ( 'DEFUN'     fun-name cfun lambda-expr doc-vv sp )
+;;;	| ( 'DEFMACRO'  macro-name cfun lambda-expr doc-vv sp )
+;;;	| ( 'ORDINARY'  expr )
+;;;	| ( 'DECLARE'   var-name-vv )
+;;;	| ( 'DEFVAR'	var-name-vv expr doc-vv )
+;;;	| ( 'CLINES'	string* )
+;;;	| ( 'LOAD-TIME-VALUE' vv )
+
+#-new-cmp
+(defvar *reservations* nil)
+(defvar *reservation-cmacro* nil)
+
+;;; *reservations* holds (... ( cmacro . value ) ...).
+;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
+
+;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
+(defvar *global-entries* nil)
+
+(defvar *self-destructing-fasl* '()
+"A value T means that, when a FASL module is being unloaded (for
+instance during garbage collection), the associated file will be
+deleted. We need this for #'COMPILE because windows DLLs cannot
+be deleted if they have been opened with LoadLibrary.")
+
+(defvar *undefined-vars* nil)
+
+;;; Only these flags are set by the user.
+;;; If (safe-compile) is ON, some kind of run-time checks are not
+;;; included in the compiled code.  The default value is OFF.
+
+(defconstant +init-env-form+
+  '((*gensym-counter* 0)
+    (*compiler-in-use* t)
+    (*compiler-phase* 't1)
+    (*callbacks* nil)
+    (*cmp-env-root* (cmp-env-copy *cmp-env-root*))
+    (*cmp-env* nil)
+    #-new-cmp
+    (*max-temp* 0)
+    #-new-cmp
+    (*temp* 0)
+    #-new-cmp
+    (*next-cmacro* 0)
+    (*next-cfun* 0)
+    (*last-label* 0)
+    (*load-objects* (make-hash-table :size 128 :test #'equal))
+    (*make-forms* nil)
+    (*static-constants* nil)
+    (*permanent-objects* nil)
+    (*temporary-objects* nil)
+    (*local-funs* nil)
+    (*global-var-objects* nil)
+    (*global-vars* nil)
+    (*global-funs* nil)
+    (*global-cfuns-array* nil)
+    (*linking-calls* nil)
+    (*global-entries* nil)
+    (*undefined-vars* nil)
+    #-new-cmp
+    (*reservations* nil)
+    (*top-level-forms* nil)
+    (*compile-time-too* nil)
+    (*clines-string-list* '())
+    (*inline-blocks* 0)
+    (*debugger-hook* 'compiler-debugger)
+    #+new-cmp
+    (*type-and-cache* (type-and-empty-cache))
+    #+new-cmp
+    (*type-or-cache* (type-or-empty-cache))
+    #+new-cmp
+    (*values-type-or-cache* (values-type-or-empty-cache))
+    #+new-cmp
+    (*values-type-and-cache* (values-type-and-empty-cache))
+    #+new-cmp
+    (*values-type-primary-type-cache* (values-type-primary-type-empty-cache))
+    #+new-cmp
+    (*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache))
+    ))
+
src/new-cmp/cmpglobals.lsp to src/cmp/cmptypes.lsp
--- a/src/new-cmp/cmpglobals.lsp
+++ b/src/cmp/cmptypes.lsp
@@ -1,7 +1,6 @@
 ;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 ;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;
 ;;;;    This program is free software; you can redistribute it and/or
 ;;;;    modify it under the terms of the GNU Library General Public
@@ -10,288 +9,242 @@
 ;;;;
 ;;;;    See file '../Copyright' for full details.
 ;;;;
-;;;;  CMPVARS -- Global variables and flag definitions
-;;;;
-
-(in-package "C-DATA")
-
-;;;
-;;; VARIABLES
-;;;
-
-;;; --cmpinline.lsp--
-;;;
-;;; Empty info struct
-;;;
-(defvar *inline-functions* nil)
-(defvar *inline-blocks* 0)
-;;; *inline-functions* holds:
-;;;	(...( function-name . inline-info )...)
-;;;
-;;; *inline-blocks* holds the number of C blocks opened for declaring
-;;; temporaries for intermediate results of the evaluation of inlined
-;;; function calls.
-
-;;; --cmputil.lsp--
-;;;
-;;; Variables and constants for error handling
-;;;
-(defvar *current-toplevel-form* '|compiler preprocess|)
-(defvar *current-form* '|compiler preprocess|)
-(defvar *current-c2form* nil)
-(defvar *compile-file-position* -1)
-(defvar *first-error* t)
-(defconstant *cmperr-tag* (cons nil nil))
-
-(defvar *active-handlers* nil)
-(defvar *active-protection* nil)
-(defvar *pending-actions* nil)
-
-(defvar *compiler-conditions* '()
-  "This variable determines whether conditions are printed or just accumulated.")
-
-(defvar *compile-print* nil
-  "This variable controls whether the compiler displays messages about
-each form it processes. The default value is NIL.")
-
-(defvar *compile-verbose* nil
-  "This variable controls whether the compiler should display messages about its
-progress. The default value is T.")
-
-(defvar *suppress-compiler-messages* nil
-  "A type denoting which compiler messages and conditions are _not_ displayed.")
-
-(defvar *suppress-compiler-notes* nil) ; Deprecated
-(defvar *suppress-compiler-warnings* nil) ; Deprecated
-
-(defvar *compiler-break-enable* nil)
-
-(defvar *compiler-in-use* nil)
-(defvar *compiler-input*)
-(defvar *compiler-output1*)
-(defvar *compiler-output2*)
-(defvar *dump-output*)
-
-;;; --cmpcbk.lsp--
-;;;
-;;; List of callbacks to be generated
-;;;
-(defvar *callbacks* nil)
-
-;;; --cmpcall.lsp--
-;;;
-;;; Whether to use linking calls.
-;;;
-(defvar *compile-to-linking-call* t)
-(defvar *compiler-declared-globals*)
-
-;;; --cmpenv.lsp--
-;;;
-;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2))
-;;;
-(defvar *safety* 2)
-(defvar *speed* 3)
-(defvar *space* 0)
-(defvar *debug* 0)
-
-;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms.
-(defvar *automatic-check-type-in-lambda* t)
-
-;;;
-;;; Compiled code uses the following kinds of variables:
-;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
-;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
-;;; 4. lexi[j], for lexical variables in local functions
-;;; 5. CLVi, for lexical variables in closures
-
-(defvar *lcl* 0)		; number of local variables
-
-(defvar *level* 0)		; nesting level for local functions
-
-(defvar *lex* 0)		; number of lexical variables in local functions
-(defvar *max-lex* 0)		; maximum *lex* reached
-
-(defvar *env* 0)		; number of variables in current form
-(defvar *max-env* 0)		; maximum *env* in whole function
-(defvar *env-lvl* 0)		; number of levels of environments
-
-(defvar *next-cfun* 0)		; holds the last cfun used.
-
-;;;
-;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
-;;; If possible, *tail-recursion-info* holds
-;;	( c1-lambda-form  required-arg .... required-arg ),
-;;; where each required-arg is a var-object.
-;;;
-(defvar *tail-recursion-info* nil)
-
-(defvar *allow-c-local-declaration* t)
-(defvar *notinline* nil)
-
-;;; --cmpexit.lsp--
-;;;
-;;; *last-label* holds the label# of the last used label.
-;;; *exit* holds an 'exit', which is
-;;	( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
-;;	RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or
-;;	RETURN-OBJECT).
-;;; *unwind-exit* holds a list consisting of:
-;;	( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
-;;	JUMP, BDS-BIND (each pushed for a single special binding), or a
-;;	LCL (which holds the bind stack pointer used to unbind).
-;;;
-(defvar *last-label* 0)
-(defvar *exit*)
-(defvar *unwind-exit*)
-
-(defvar *current-function* nil)
-
-(defvar *cmp-env* (cons nil nil)
-"The compiler environment consists of a pair or cons of two
-lists, one containing variable records, the other one macro and
-function recors:
-
-variable-record = (:block block-name) |
-                  (:tag ({tag-name}*)) |
-                  (:function function-name) |
-                  (var-name {:special | nil} bound-p) |
-                  (symbol si::symbol-macro macro-function) |
-                  CB | LB | UNWIND-PROTECT
-macro-record =	(function-name function) |
-                (macro-name si::macro macro-function)
-                CB | LB | UNWIND-PROTECT
-
-A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
-MACRO-FUNCTION is a function that provides us with the expansion
-for that local macro or symbol macro. BOUND-P is true when the
-variable has been bound by an enclosing form, while it is NIL if
-the variable-record corresponds just to a special declaration.
-CB, LB and UNWIND-PROTECT are only used by the C compiler and
-they denote closure, lexical environment and unwind-protect
-boundaries. Note that compared with the bytecodes compiler, these
-records contain an additional variable, block, tag or function
-object at the end.")
-
-;;; --cmplog.lsp--
-;;;
-;;; Destination of output of different forms. See cmploc.lsp for types
-;;; of destinations.
-;;;
-(defvar *destination*)
-
-;;; --cmpmain.lsp--
-;;;
-;;; Do we debug the compiler? Then we need files not to be deleted.
-
-(defvar *debug-compiler* nil)
-(defvar *delete-files* t)
-(defvar *files-to-be-deleted* '())
-
-;;; --cmptop.lsp--
-;;;
-(defvar *do-type-propagation* nil
-  "Flag for switching on the type propagation phase. Use with care, experimental.")
-
-(defvar *compiler-phase* nil)
-
-(defvar *volatile*)
-
-(defvar *compile-toplevel* T
-  "Holds NIL or T depending on whether we are compiling a toplevel form.")
-(defvar *compile-time-too* nil)
-
-(defvar *clines-string-list* '()
-  "List of strings containing C/C++ statements which are directly inserted
-in the translated C/C++ file. Notice that it is unspecified where these
-lines are inserted, but the order is preserved")
-
-(defvar *permanent-data* nil)		; detemines whether we use *permanent-objects*
-					; or *temporary-objects*
-(defvar *permanent-objects* nil)	; holds { ( object (VV vv-index) ) }*
-(defvar *temporary-objects* nil)	; holds { ( object (VV vv-index) ) }*
-(defvar *load-objects* nil)		; hash with association object -> vv-location
-(defvar *load-time-values* nil)		; holds { ( vv-index form ) }*,
-;;;  where each vv-index should be given an object before
-;;;  defining the current function during loading process.
-
-(defvar *use-static-constants-p* t)     ; T/NIL flag to determine whether one may
-                                        ; generate lisp constant values as C structs
-
-(defvar *compiler-constants* nil)	; a vector with all constants
-					; only used in COMPILE
-
-(defvar *proclaim-fixed-args* nil)	; proclaim automatically functions
-					; with fixed number of arguments.
-					; watch out for multiple values.
-
-(defvar *global-var-objects* nil)	; var objects for global/special vars
-(defvar *global-vars* nil)		; variables declared special
-(defvar *global-funs* nil)		; holds	{ fun }*
-(defvar *global-cfuns-array* nil)	; holds	{ fun }*
-(defvar *linking-calls* nil)		; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
-(defvar *local-funs* nil)		; holds { fun }*
-(defvar *top-level-forms* nil)		; holds { top-level-form }*
-(defvar *make-forms* nil)		; holds { top-level-form }*
-(defvar +init-function-name+ (gensym "ENTRY-POINT"))
-
-;;;
-;;;     top-level-form:
-;;;	  ( 'DEFUN'     fun-name cfun lambda-expr doc-vv sp )
-;;;	| ( 'DEFMACRO'  macro-name cfun lambda-expr doc-vv sp )
-;;;	| ( 'ORDINARY'  expr )
-;;;	| ( 'DECLARE'   var-name-vv )
-;;;	| ( 'DEFVAR'	var-name-vv expr doc-vv )
-;;;	| ( 'CLINES'	string* )
-;;;	| ( 'LOAD-TIME-VALUE' vv )
-
-(defvar *reservation-cmacro* nil)
-
-;;; *reservations* holds (... ( cmacro . value ) ...).
-;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
-
-(defvar *self-destructing-fasl* '()
-"A value T means that, when a FASL module is being unloaded (for
-instance during garbage collection), the associated file will be
-deleted. We need this for #'COMPILE because windows DLLs cannot
-be deleted if they have been opened with LoadLibrary.")
-
-(defvar *undefined-vars* nil)
-
-;;; Only these flags are set by the user.
-;;; If (safe-compile) is ON, some kind of run-time checks are not
-;;; included in the compiled code.  The default value is OFF.
-
-(defconstant +init-env-form+
-  '((*gensym-counter* 0)
-    (*compiler-in-use* t)
-    (*compiler-phase* 't1)
-    (*callbacks* nil)
-    (*next-cfun* 0)
-    (*lcl* 0)
-    (*last-label* 0)
-    (*load-objects* (make-hash-table :size 128 :test #'equal))
-    (*make-forms* nil)
-    (*static-constants* nil)
-    (*permanent-objects* nil)
-    (*temporary-objects* nil)
-    (*local-funs* nil)
-    (*global-var-objects* nil)
-    (*global-vars* nil)
-    (*global-funs* nil)
-    (*global-cfuns-array* nil)
-    (*linking-calls* nil)
-    (*global-entries* nil)
-    (*undefined-vars* nil)
-    (*top-level-forms* nil)
-    (*clines-string-list* '())
-    (*inline-functions* nil)
-    (*inline-blocks* 0)
-    (*debugger-hook* 'compiler-debugger)
-    (*type-and-cache* (type-and-empty-cache))
-    (*type-or-cache* (type-or-empty-cache))
-    (*values-type-or-cache* (values-type-or-empty-cache))
-    (*values-type-and-cache* (values-type-and-empty-cache))
-    (*values-type-primary-type-cache* (values-type-primary-type-empty-cache))
-    (*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache))
-    ))
-
+;;;;  CMPTYPES -- Data types for the Lisp core structures
+;;;;
+
+(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; COMPILER STRUCTURES
+;;;
+
+;;;
+;;; REF OBJECT
+;;;
+;;; Base object for functions, variables and statements. We use it to
+;;; keep track of references to objects, how many times the object is
+;;; referenced, by whom, and whether the references cross some closure
+;;; boundaries.
+;;;
+
+(defstruct (ref (:print-object print-ref))
+  name			;;; Identifier of reference.
+  (ref 0 :type fixnum)	;;; Number of references.
+  ref-ccb		;;; Cross closure reference.
+			;;; During Pass1, T or NIL.
+			;;; During Pass2, the index into the closure env
+  ref-clb		;;; Cross local function reference.
+			;;; During Pass1, T or NIL.
+			;;; During Pass2, the lex-address for the
+			;;; block id, or NIL.
+  read-nodes		;;; Nodes (c1forms) in which the reference occurs
+)
+
+(deftype OBJECT () `(not (or fixnum character float)))
+
+(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var))
+;  name		;;; Variable name.
+;  (ref 0 :type fixnum)
+		;;; Number of references to the variable (-1 means IGNORE).
+;  ref-ccb	;;; Cross closure reference: T or NIL.
+;  ref-clb	;;; Cross local function reference: T or NIL.
+;  read-nodes	;;; Nodes (c1forms) in which the reference occurs
+  set-nodes	;;; Nodes in which the variable is modified
+  kind		;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
+  		;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
+		;;; LET variables).
+  (function *current-function*)
+		;;; For local variables, in which function it was created.
+		;;; For global variables, it doesn't have a meaning.
+  (functions-setting nil)
+  (functions-reading nil)
+		;;; Functions in which the variable has been modified or read.
+  (loc 'OBJECT)	;;; During Pass 1: indicates whether the variable can
+		;;; be allocated on the c-stack: OBJECT means
+		;;; the variable is declared as OBJECT, and CLB means
+		;;; the variable is referenced across Level Boundary and thus
+		;;; cannot be allocated on the C stack.  Note that OBJECT is
+		;;; set during variable binding and CLB is set when the
+		;;; variable is used later, and therefore CLB may supersede
+		;;; OBJECT.
+		;;; During Pass 2:
+  		;;; For REPLACED: the actual location of the variable.
+  		;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
+  		;;;   the cvar for the C variable that holds the value.
+  		;;; For LEXICAL or CLOSURE: the frame-relative address for
+		;;; the variable in the form of a cons '(lex-levl . lex-ndx)
+		;;;	lex-levl is the level of lexical environment
+		;;;	lex-ndx is the index within the array for this env.
+		;;; For SPECIAL and GLOBAL: the vv-index for variable name.
+  (type t)	;;; Type of the variable.
+  #-new-cmp
+  (index -1)    ;;; position in *vars*. Used by similar.
+  #-new-cmp
+  (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration
+  #+new-cmp
+  read-only-p   ;;; T for variables that are assigned only once.
+  )
+
+;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE
+;;; Here are examples of function FOO for the 3 cases:
+;;; 1.  (flet ((foo () (bar))) (foo))		CFUN
+;;; 2.  (flet ((foo () (bar))) #'foo)		CFUN+LISP_CFUN
+;;; 3.  (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE
+;;; 4.  (flet ((foo () x)) #'foo)		CCLOSURE+LISP_CLOSURE
+
+;;; A function can be referred across a ccb without being a closure, e.g:
+;;;   (flet ((foo () (bar))) #'(lambda () (foo)))
+;;;   [the lambda also need not be a closure]
+;;; and it can be a closure without being referred across ccb, e.g.:
+;;;   (flet ((foo () x)) #'foo)  [ is this a mistake in local-function-ref?]
+;;; Here instead the lambda must be a closure, but no closure is needed for foo
+;;;   (flet ((foo () x)) #'(lambda () (foo)))
+;;; So we use two separate fields: ref-ccb and closure.
+;;; A CCLOSURE must be created for a function when:
+;;; 1. it appears within a FUNCTION construct and
+;;; 2. it uses some ccb references (directly or indirectly).
+;;; ref-ccb corresponds to the first condition, i.e. function is referred
+;;;   across CCB. It is computed during Pass 1. A value of 'RETURNED means
+;;;   that it is immediately within FUNCTION.
+;;; closure corresponds to second condition and is computed in Pass 2 by
+;;;   looking at the info-referred-vars and info-local-referred of its body.
+
+;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned.
+;;; The LISP funob may then be referred locally or across LB or CB:
+;;;     (flet ((foo (z) (bar z))) (list #'foo)))
+;;;     (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar)))
+;;;     (flet ((foo (z) (bar z))) #'(lambda () #'foo)))
+;;; therefore we need field funob.
+
+(defstruct (fun (:include ref))
+;  name			;;; Function name.
+;  (ref 0 :type fixnum)	;;; Number of references.
+			;;; During Pass1, T or NIL.
+			;;; During Pass2, the vs-address for the
+			;;; function closure, or NIL.
+;  ref-ccb		;;; Cross closure reference.
+ 			;;; During Pass1, T or NIL, depending on whether a
+			;;; function object will be built.
+			;;; During Pass2, the vs-address for the function
+			;;; closure, or NIL.
+;  ref-clb		;;; Unused.
+;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
+  cfun			;;; The cfun for the function.
+  #+new-cmp
+  (last-lcl 0)		;;; Number of local variables (just to bookkeep names)
+  #+new-cmp
+  (last-label 0)	;;; Number of generated labels (same as last-lcl)
+  (level 0)		;;; Level of lexical nesting for a function.
+  (env 0)     		;;; Size of env of closure.
+  (global nil)		;;; Global lisp function.
+  (exported nil)	;;; Its C name can be seen outside the module.
+  (no-entry nil)	;;; NIL if declared as C-LOCAL. Then we create no
+			;;; function object and the C function is called
+			;;; directly
+  (shares-with nil)	;;; T if this function shares the C code with another one.
+			;;; In that case we need not emit this one.
+  closure		;;; During Pass2, T if env is used inside the function
+  var			;;; the variable holding the funob
+  description		;;; Text for the object, in case NAME == NIL.
+  #+new-cmp
+  lambda-list		;;; List of (requireds optionals rest-var keywords-p
+		        ;;;          keywords allow-other-keys-p)
+  lambda		;;; Lambda c1-form for this function.
+  (minarg 0)		;;; Min. number arguments that the function receives.
+  (maxarg call-arguments-limit)
+			;;; Max. number arguments that the function receives.
+  #+new-cmp
+  doc			;;; Documentation
+  (parent *current-function*)
+			;;; Parent function, NIL if global.
+  (local-vars nil)	;;; List of local variables created here.
+  (referred-vars nil)	;;; List of external variables referenced here.
+  (referred-funs nil)	;;; List of external functions called in this one.
+			;;; We only register direct calls, not calls via object.
+  (child-funs nil)	;;; List of local functions defined here.
+  #+new-cmp
+  (debug 0)		;;; Debug quality
+  (file (car ext:*source-location*))
+			;;; Source file or NIL
+  (file-position (or (cdr ext:*source-location*) *compile-file-position*))
+			;;; Top-level form number in source file
+  #+new-cmp
+  (toplevel-form *current-toplevel-form*)
+  #+new-cmp
+  code-gen-props	;;; Extra properties for code generation
+  (cmp-env (cmp-env-copy)) ;;; Environment
+  )
+
+(defstruct (blk (:include ref))
+;  name			;;; Block name.
+;  (ref 0 :type fixnum)	;;; Number of references.
+;  ref-ccb		;;; Cross closure reference.
+			;;; During Pass1, T or NIL.
+			;;; During Pass2, the ccb-lex for the
+			;;; block id, or NIL.
+;  ref-clb		;;; Cross local function reference.
+			;;; During Pass1, T or NIL.
+			;;; During Pass2, the lex-address for the
+			;;; block id, or NIL.
+;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
+  exit			;;; Where to return.  A label.
+  destination		;;; Where the value of the block to go.
+  var			;;; Variable containing the block ID.
+  #-new-cmp
+  (type 'NIL)		;;; Estimated type.
+  #+new-cmp
+  env                   ;;; Block environment.
+  )
+
+(defstruct (tag (:include ref))
+;  name			;;; Tag name.
+;  (ref 0 :type fixnum)	;;; Number of references.
+;  ref-ccb		;;; Cross closure reference.
+			;;; During Pass1, T or NIL.
+;  ref-clb		;;; Cross local function reference.
+			;;; During Pass1, T or NIL.
+;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
+  label			;;; Where to jump: a label.
+  unwind-exit		;;; Where to unwind-no-exit.
+  var			;;; Variable containing frame ID.
+  index			;;; An integer denoting the label.
+  #+new-cmp
+  env                   ;;; Tag environment.
+  )
+
+(defstruct (info)
+  (local-vars nil)	;;; List of var-objects created directly in the form.
+   #-new-cmp
+  (type t)		;;; Type of the form.
+  (sp-change nil)	;;; Whether execution of the form may change
+			;;; the value of a special variable.
+  (volatile nil)	;;; whether there is a possible setjmp. Beppe
+  )
+
+(defstruct (inline-info)
+  name			;;; Function name
+  arg-rep-types		;;; List of representation types for the arguments
+  return-rep-type	;;; Representation type for the output
+  arg-types		;;; List of lisp types for the arguments
+  return-type		;;; Lisp type for the output
+  exact-return-type	;;; Only use this expansion when the output is
+			;;; declared to have a subtype of RETURN-TYPE
+  expansion		;;; C template containing the expansion
+  one-liner		;;; Whether the expansion spans more than one line
+)
+
+(defstruct (c1form (:include info)
+		   (:print-object print-c1form)
+		   (:constructor do-make-c1form))
+  (name nil)
+  (parent nil)
+  #+new-cmp
+  (env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled
+  #-new-cmp
+  (env (cmp-env-copy)) ;; Environment in which this form was compiled
+  (args '())
+  (form nil)
+  (toplevel-form nil)
+  (file nil)
+  (file-position 0))
src/new-cmp/cmptypes.lsp to src/cmp/cmpenv-declare.lsp
--- a/src/new-cmp/cmptypes.lsp
+++ b/src/cmp/cmpenv-declare.lsp
@@ -1,7 +1,6 @@
 ;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 ;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;
 ;;;;    This program is free software; you can redistribute it and/or
 ;;;;    modify it under the terms of the GNU Library General Public
@@ -10,219 +9,209 @@
 ;;;;
 ;;;;    See file '../Copyright' for full details.
 ;;;;
-;;;;  CMPTYPES -- Data types for the Lisp core structures
-;;;;
-
-(in-package "C-DATA")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; COMPILER STRUCTURES
-;;;
-
-;;;
-;;; REF OBJECT
-;;;
-;;; Base object for functions, variables and statements. We use it to
-;;; keep track of references to objects, how many times the object is
-;;; referenced, by whom, and whether the references cross some closure
-;;; boundaries.
-;;;
-
-(defstruct (ref (:print-object print-ref))
-  name			;;; Identifier of reference.
-  (ref 0 :type fixnum)	;;; Number of references.
-  ref-ccb		;;; Cross closure reference.
-			;;; During Pass1, T or NIL.
-			;;; During Pass2, the index into the closure env
-  ref-clb		;;; Cross local function reference.
-			;;; During Pass1, T or NIL.
-			;;; During Pass2, the lex-address for the
-			;;; block id, or NIL.
-  read-nodes		;;; Nodes (c1forms) in which the reference occurs
-)
-
-(deftype OBJECT () `(not (or fixnum character float)))
-
-(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var))
-;  name		;;; Variable name.
-;  (ref 0 :type fixnum)
-		;;; Number of references to the variable (-1 means IGNORE).
-;  ref-ccb	;;; Cross closure reference: T or NIL.
-;  ref-clb	;;; Cross local function reference: T or NIL.
-;  read-nodes	;;; Nodes (c1forms) in which the reference occurs
-  set-nodes	;;; Nodes in which the variable is modified
-  kind		;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
-  		;;; :CHAR, :DOUBLE, :FLOAT, REPLACED or DISCARDED
-  (function *current-function*)
-		;;; For local variables, in which function it was created.
-		;;; For global variables, it doesn't have a meaning.
-  (functions-setting nil)
-  (functions-reading nil)
-		;;; Functions in which the variable has been modified or read.
-  (loc 'OBJECT)	;;; During Pass 1: indicates whether the variable can
-		;;; be allocated on the c-stack: OBJECT means
-		;;; the variable is declared as OBJECT, and CLB means
-		;;; the variable is referenced across Level Boundary and thus
-		;;; cannot be allocated on the C stack.  Note that OBJECT is
-		;;; set during variable binding and CLB is set when the
-		;;; variable is used later, and therefore CLB may supersede
-		;;; OBJECT.
-		;;; During Pass 2:
-  		;;; For REPLACED: the actual location of the variable.
-  		;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
-  		;;;   the cvar for the C variable that holds the value.
-  		;;; For LEXICAL or CLOSURE: the frame-relative address for
-		;;; the variable in the form of a cons '(lex-levl . lex-ndx)
-		;;;	lex-levl is the level of lexical environment
-		;;;	lex-ndx is the index within the array for this env.
-		;;; For SPECIAL and GLOBAL: the vv-index for variable name.
-  (type t)	;;; Type of the variable.
-  read-only-p   ;;; T for variables that are assigned only once.
-  )
-
-;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE
-;;; Here are examples of function FOO for the 3 cases:
-;;; 1.  (flet ((foo () (bar))) (foo))		CFUN
-;;; 2.  (flet ((foo () (bar))) #'foo)		CFUN+LISP_CFUN
-;;; 3.  (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE
-;;; 4.  (flet ((foo () x)) #'foo)		CCLOSURE+LISP_CLOSURE
-
-;;; A function can be referred across a ccb without being a closure, e.g:
-;;;   (flet ((foo () (bar))) #'(lambda () (foo)))
-;;;   [the lambda also need not be a closure]
-;;; and it can be a closure without being referred across ccb, e.g.:
-;;;   (flet ((foo () x)) #'foo)  [ is this a mistake in local-function-ref?]
-;;; Here instead the lambda must be a closure, but no closure is needed for foo
-;;;   (flet ((foo () x)) #'(lambda () (foo)))
-;;; So we use two separate fields: ref-ccb and closure.
-;;; A CCLOSURE must be created for a function when:
-;;; 1. it appears within a FUNCTION construct and
-;;; 2. it uses some ccb references (directly or indirectly).
-;;; ref-ccb corresponds to the first condition, i.e. function is referred
-;;;   across CCB. It is computed during Pass 1. A value of 'RETURNED means
-;;;   that it is immediately within FUNCTION.
-;;; closure corresponds to second condition and is computed in Pass 2 by
-;;;   looking at the info-referred-vars and info-local-referred of its body.
-
-;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned.
-;;; The LISP funob may then be referred locally or across LB or CB:
-;;;     (flet ((foo (z) (bar z))) (list #'foo)))
-;;;     (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar)))
-;;;     (flet ((foo (z) (bar z))) #'(lambda () #'foo)))
-;;; therefore we need field funob.
-
-(defstruct (fun (:include ref))
-;  name			;;; Function name.
-;  (ref 0 :type fixnum)	;;; Number of references.
-			;;; During Pass1, T or NIL.
-			;;; During Pass2, the vs-address for the
-			;;; function closure, or NIL.
-;  ref-ccb		;;; Cross closure reference.
- 			;;; During Pass1, T or NIL, depending on whether a
-			;;; function object will be built.
-			;;; During Pass2, the vs-address for the function
-			;;; closure, or NIL.
-;  ref-clb		;;; Unused.
-;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
-  cfun			;;; The cfun for the function.
-  (last-lcl 0)		;;; Number of local variables (just to bookkeep names)
-  (last-label 0)	;;; Number of generated labels (same as last-lcl)
-  (level 0)		;;; Level of lexical nesting for a function.
-  (env 0)     		;;; Size of env of closure.
-  (global nil)		;;; Global lisp function.
-  (exported nil)	;;; Its C name can be seen outside the module.
-  (no-entry nil)	;;; NIL if declared as C-LOCAL. Then we create no
-			;;; function object and the C function is called
-			;;; directly
-  (shares-with nil)	;;; T if this function shares the C code with another one.
-			;;; In that case we need not emit this one.
-  closure		;;; During Pass2, T if env is used inside the function
-  var			;;; the variable holding the funob
-  description		;;; Text for the object, in case NAME == NIL.
-  lambda-list		;;; List of (requireds optionals rest-var keywords-p
-		        ;;;          keywords allow-other-keys-p)
-  (minarg 0)		;;; Min. number arguments that the function receives.
-  (maxarg call-arguments-limit)
-			;;; Max. number arguments that the function receives.
-  lambda		;;; Lambda c1-form for this function.
-  doc			;;; Documentation
-  (parent *current-function*)
-			;;; Parent function, NIL if global.
-  (local-vars nil)	;;; List of local variables created here.
-  (referred-vars nil)	;;; List of external variables referenced here.
-  (referred-funs nil)	;;; List of external functions called in this one.
-			;;; We only register direct calls, not calls via object.
-  (child-funs nil)	;;; List of local functions defined here.
-  (debug 0)		;;; Debug quality
-  (file *compile-file-truename*)
-			;;; Source file or NIL
-  (file-position *compile-file-position*)
-			;;; Top-level form number in source file
-  (toplevel-form *current-toplevel-form*)
-  code-gen-props	;;; Extra properties for code generation
-  )
-
-(defstruct (blk (:include ref))
-;  name			;;; Block name.
-;  (ref 0 :type fixnum)	;;; Number of references.
-;  ref-ccb		;;; Cross closure reference.
-			;;; During Pass1, T or NIL.
-			;;; During Pass2, the ccb-lex for the
-			;;; block id, or NIL.
-;  ref-clb		;;; Cross local function reference.
-			;;; During Pass1, T or NIL.
-			;;; During Pass2, the lex-address for the
-			;;; block id, or NIL.
-;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
-  exit			;;; Where to return.  A label.
-  destination		;;; Where the value of the block to go.
-  var			;;; Variable containing the block ID.
-  env			;;; Block environment
-  )
-
-(defstruct (tag (:include ref))
-;  name			;;; Tag name.
-;  (ref 0 :type fixnum)	;;; Number of references.
-;  ref-ccb		;;; Cross closure reference.
-			;;; During Pass1, T or NIL.
-;  ref-clb		;;; Cross local function reference.
-			;;; During Pass1, T or NIL.
-;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
-  label			;;; Where to jump: a label.
-  unwind-exit		;;; Where to unwind-no-exit.
-  var			;;; Variable containing frame ID.
-  index			;;; An integer denoting the label.
-  env			;;; Tag environment
-  )
-
-(defstruct (info)
-  )
-
-(defstruct (inline-info)
-  name			;;; Function name
-  arg-rep-types		;;; List of representation types for the arguments
-  return-rep-type	;;; Representation type for the output
-  arg-types		;;; List of lisp types for the arguments
-  return-type		;;; Lisp type for the output
-  exact-return-type	;;; Only use this expansion when the output is
-			;;; declared to have a subtype of RETURN-TYPE
-  expansion		;;; C template containing the expansion
-  one-liner		;;; Whether the expansion spans more than one line
-)
-
-(defstruct (c1form (:include info)
-		   (:print-object print-c1form)
-		   (:constructor do-make-c1form))
-  (name nil)            ;; See cmptables.lsp for all valid form names
-  (args '())            ;; Arguments
-  (env (c-env:cmp-env-copy))  ;; Environment in which this form was compiled
-  (local-vars nil)	;; List of var-objects created directly in the form.
-  (sp-change nil)	;; Whether execution of the form may change
-			;; the value of a special variable.
-  (volatile nil)	;; whether there is a possible setjmp. Beppe
-
-  (form nil)            ;; Origin of this form
-  (toplevel-form)       ;; ... including toplevel form in which it appears
-  (file nil)            ;; ... and source file and position
-  (file-position 0))
+;;;; CMPENV-DECLARE -- Declarations for the compiler
+;;;;
+;;;; Extract, process and incorporate declarations into the compiler
+;;;; environment. Unlike proclamations, these are local to the current
+;;;; compiled file and do not propagate beyond it.
+;;;;
+
+(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
+
+(defun proper-list-p (x &optional test)
+  (and (listp x)
+       (handler-case (list-length x) (type-error (c) nil))
+       (or (null test) (every test x))))
+
+(defun type-name-p (name)
+  (or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
+      (find-class name nil)
+      (get-sysprop name 'SI::STRUCTURE-TYPE)))
+
+(defun validate-alien-declaration (names-list error)
+  (dolist (new-declaration names-list)
+    (unless (symbolp new-declaration)
+      (cmperr "The declaration ~s is not a symbol" new-declaration))
+    (when (type-name-p new-declaration)
+      (cmperr "Symbol name ~S cannot be both the name of a type and of a declaration"
+              new-declaration))))
+
+(defun alien-declaration-p (name &optional (env *cmp-env*))
+  (or (member name si::*alien-declarations*)
+      (member name (cmp-env-search-declaration 'alien env))))
+
+(defun parse-ignore-declaration (decl-args expected-ref-number tail)
+  (declare (si::c-local))
+  (loop for name in decl-args
+     do (if (symbolp name)
+            (push (cons name expected-ref-number) tail)
+            (cmpassert (and (consp name)
+                            (= (length name) 2)
+                            (eq (first name) 'function))
+                       "Invalid argument to IGNORE/IGNORABLE declaration:~&~A"
+                       name)))
+  tail)
+
+(defun collect-declared (type var-list tail)
+  (declare (si::c-local))
+  (cmpassert (proper-list-p var-list #'symbolp)
+             "Syntax error in declaration ~s" decl)
+  (loop for var-name in var-list
+     do (push (cons var-name type) tail))
+  tail)
+
+(defun c1body (body doc-p)
+  "Split a function body into a list of forms, a set of declarations,
+and a possible documentation string (only accepted when DOC-P is true)."
+  (multiple-value-bind (all-declarations body doc specials)
+      (si:process-declarations body doc-p)
+    (loop with others = '()
+       with types = '()
+       with ignored = '()
+       for decl in all-declarations
+       for decl-name = (first decl)
+       for decl-args = (rest decl)
+       do (cmpassert (and (proper-list-p decl-args) (symbolp decl-name))
+                     "Syntax error in declaration ~s" decl)
+       do (case decl-name
+            (SPECIAL)
+            (IGNORE
+             (cmpassert (proper-list-p decl-args #'symbolp)
+                        "Syntax error in declaration ~s" decl)
+             (setf ignored (parse-ignore-declaration decl-args -1 ignored)))
+            (IGNORABLE
+             (cmpassert (proper-list-p decl-args #'symbolp)
+                        "Syntax error in declaration ~s" decl)
+             (setf ignored (parse-ignore-declaration decl-args 0 ignored)))
+            (TYPE
+             (cmpassert (and (consp decl-args)
+                             (proper-list-p (rest decl-args) #'symbolp))
+                        "Syntax error in declaration ~s" decl)
+             (setf types (collect-declared (first decl-args)
+                                           (rest decl-args)
+                                           types)))
+            (OBJECT
+             (cmpassert (proper-list-p decl-args #'symbolp)
+                        "Syntax error in declaration ~s" decl)
+             (setf types (collect-declared 'OBJECT decl-args types)))
+            ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL
+              SI::C-GLOBAL DYNAMIC-EXTENT IGNORABLE VALUES
+              SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY)
+             (push decl others))
+            (otherwise
+             (if (alien-declaration-p decl-name)
+                 (push decl others)
+                 (multiple-value-bind (ok type)
+                     (valid-type-specifier decl-name)
+                   (cmpassert ok "Unknown declaration specifier ~s"
+                              decl-name)
+                   (setf types (collect-declared type decl-args types))))))
+       finally (return (values body specials types ignored
+                               (nreverse others) doc all-declarations)))))
+
+(defun default-optimization (optimization)
+  (ecase optimization
+    (speed *speed*)
+    (safety *safety*)
+    (space *space*)
+    (debug *debug*)))
+
+(defun search-optimization-quality (declarations what)
+  (dolist (i (reverse declarations)
+	   (default-optimization what))
+    (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
+               (eq what 'debug))
+      (return 2))      
+    (when (and (consp i) (eq (first i) 'optimize))
+      (dolist (j (rest i))
+	(cond ((consp j)
+	       (when (eq (first j) what)
+		 (return-from search-optimization-quality (second j))))
+	      ((eq j what)
+	       (return-from search-optimization-quality 3)))))))
+
+(defun compute-optimizations (arguments env)
+  (let ((optimizations (cmp-env-all-optimizations env)))
+    (dolist (x arguments)
+      (when (symbolp x) (setq x (list x 3)))
+      (unless optimizations
+        (setq optimizations (cmp-env-all-optimizations)))
+      (if (or (not (consp x))
+              (not (consp (cdr x)))
+              (not (numberp (second x)))
+              (not (<= 0 (second x) 3)))
+          (cmpwarn "Illegal OPTIMIZE proclamation ~s" x)
+          (let ((value (second x)))
+            (case (car x)
+              (DEBUG (setf (first optimizations) value))
+              (SAFETY (setf (second optimizations) value))
+              (SPACE (setf (third optimizations) value))
+              (SPEED (setf (fourth optimizations) value))
+              (COMPILATION-SPEED)
+              (t (cmpwarn "Unknown OPTIMIZE quality ~s" (car x)))))))
+    optimizations))
+
+(defun add-one-declaration (env decl)
+  "Add to the environment one declarations which is not type, ignorable or
+special variable declarations, as these have been extracted before."
+  (case (car decl)
+    (OPTIMIZE
+     (let ((optimizations (compute-optimizations (rest decl) env)))
+       (cmp-env-add-declaration 'optimize optimizations env)))
+    (POLICY-DEBUG-IHS-FRAME
+     (let ((flag (or (rest decl) '(t))))
+       (if *current-function*
+           (progn
+             (cmp-env-add-declaration 'policy-debug-ihs-frame flag
+                                      (fun-cmp-env *current-function*))
+             env)
+           (cmp-env-add-declaration 'policy-debug-ihs-frame
+                                    flag env))))
+    (FTYPE
+     (if (atom (rest decl))
+         (cmpwarn "Syntax error in declaration ~a" decl)
+         (multiple-value-bind (type-name args)
+             (si::normalize-type (second decl))
+           (if (eq type-name 'FUNCTION)
+               (dolist (v (cddr decl))
+                 (setf env (add-function-declaration v (first args)
+                                                     (rest args) env)))
+               (cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
+                        (second decl)))))
+     env)
+    (INLINE
+      (declare-inline (rest decl) env))
+    (NOTINLINE
+     (setf env (declare-notinline (rest decl) env)))
+    (DECLARATION
+     (validate-alien-declaration (rest decl) #'cmperr)
+     (setf env (cmp-env-extend-declaration 'alien (rest decl) env)))
+    ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY)
+     env)
+    ((DYNAMIC-EXTENT IGNORABLE)
+     ;; FIXME! SOME ARE IGNORED!
+     env)
+    (otherwise
+     (unless (alien-declaration-p (first decl) env)
+       (cmpwarn "Unknown declaration specifier ~s" (first decl)))
+     env)))
+
+(defun symbol-macro-declaration-p (name type)
+  (let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*)))
+    (when (and record (functionp record))
+      (let* ((expression (funcall record name nil)))
+        (cmp-env-register-symbol-macro name `(the ,type ,expression)))
+      t)))
+
+(defun check-vdecl (vnames ts is)
+  (loop for (var . type) in ts
+     unless (or (member var vnames :test #'eq)
+                (symbol-macro-declaration-p var type))
+     do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
+                 type var))
+  (loop for (var . expected-uses) in is
+     unless (member var vnames :test #'eq)
+     do (cmpwarn (if (minusp expected-uses)
+                     "IGNORE declaration was found for not bound variable ~s."
+                     "IGNORABLE declaration was found for not bound variable ~s.")
+                 var)))
1 2 3 > >> (Page 1 of 3)