;;; -*- Mode: Common-Lisp; Package: compiler; Base: 10.; Patch-File: T -*-

;;; Reason: Conformance changes.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 06/12/90 14:32:12 by BERGER,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.38, VIRTUAL-MEMORY 6.3, EH 6.8, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.5, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.8, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.1, BASIC-FILE 6.13, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.18, TV 6.26, DATALINK 6.0, CHAOSNET 6.8, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.3,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.2, ZWEI 6.21,
;;;  DEBUG-TOOLS 6.5, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.3, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.7, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.6, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.51, CLEH 6.5, IP 3.65,
;;;  Experimental CLX 6.11, CLUE 6.105, X11M 6.30, Experimental BUG 11.19, VISIDOC-SERVER 6.2,
;;;   microcode 483, Band Name: 6.1-A 5-31 +P6/4


#!C
; From file MINDEFS.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; MINDEFS.É#É"


(SI:BOOTSTRAP-EXPORT '(
		       *CONFORMANCE*   
		       CONFORMANCE-WARNING
		       CHECK-CONFORMANCE	;PARSE-BODY, SYS::COMPILE-FLAVOR-METHODS-1, SYS::SHARP-COMMA, etc.
		       ) "COMPILER2" )

(SYS::BOOTSTRAP-EXPORT
 '(COMMON-LISP:*COMPILE-VERBOSE* COMMON-LISP:*COMPILE-PRINT* COMMON-LISP:DEBUG
   COMMON-LISP:DYNAMIC-EXTENT LOAD-TIME-VALUE COMMON-LISP:STYLE-WARNING MAKE-LOAD-FORM
   MAKE-LOAD-FORM-SAVING-SLOTS COMMON-LISP:DEFINE-COMPILER-MACRO
   COMMON-LISP:COMPILER-MACRO-FUNCTION COMMON-LISP::COMPILER-MACROEXPAND
   COMMON-LISP::COMPILER-MACROEXPAND-1)
 "COMPILER2")

(DEFVAR COMPILER::*CONFORMANCE* NIL
   "Default value for the compiler's conformance checking option.
Possible values and their meanings are:
  NIL	-> No conformance checking is done.
  :ANSI	-> Check conformance to proposed ANSI Common Lisp.
  :CLTL	-> Check conformance to \"Common Lisp the Language\", 1st edition (1984).
  :CLTL+CLOS -> Same as :CLTL but allows CLEH symbols and compiler:*ok-symbols*.
  T	-> Warn about features not included in either CLtL or ANSI Common Lisp. ")

(DEFVAR COMPILER::CHECK-CONFORMANCE NIL)

(COMMENT
(EVAL-WHEN (EVAL COMPILE LOAD)
  (WHEN (EQ (FIND-SYMBOL "PROCLAIM" "CL") 'PROCLAIM)
    (UNINTERN 'PROCLAIM "CL")
    (EXPORT (INTERN "PROCLAIM" "CL") "CL")))
(DEFUN PROCLAIM (COMPILER::DECLARATION-SPECIFIER)
  (PROCLAIM COMPILER::DECLARATION-SPECIFIER))
(SETF (DOCUMENTATION 'PROCLAIM 'FUNCTION) (DOCUMENTATION 'PROCLAIM 'FUNCTION)))
 


(DEFMACRO COMMON-LISP:DECLAIM (&REST COMPILER::DECL-SPECS)
  "This macro PROCLAIMs the given DECL-SPECS, which are not evaluated.
If a call to this macro appears at top-level in a file being processed by
COMPILE-FILE, the proclamations are also made at compile-time."
  (CONS 'PROCLAIM (MAPCAR #'(LAMBDA (COMPILER::X)
			      `',COMPILER::X) COMPILER::DECL-SPECS))) 

(UNLESS (FBOUNDP 'COMPILER::CONFORMANCE-WARNING)
  (SETF (SYMBOL-FUNCTION 'COMPILER::CONFORMANCE-WARNING) #'IGNORE))


))





#!C
; From file DEFS.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; DEFS.É#É"


(DEFSUBST COMPILER::IN-SOURCE-AREA-P (COMPILER::FORM)
  (EQ (SYS:%AREA-NUMBER COMPILER::FORM) COMPILER::SOURCE-CODE-AREA)) 


(DEFCONSTANT COMPILER::GENERATING-MICRO-COMPILER-INPUT-P NIL) 


(DEFVAR COMMON-LISP:*COMPILE-PRINT*) 


(FORWARD-VALUE-CELL 'COMMON-LISP:*COMPILE-PRINT* 'COMPILER:COMPILER-VERBOSE) 


(SETF (DOCUMENTATION 'COMMON-LISP:*COMPILE-PRINT* 'VARIABLE)
      (DOCUMENTATION 'COMPILER:COMPILER-VERBOSE 'VARIABLE)) 


(DEFVAR COMMON-LISP:*COMPILE-VERBOSE* NIL
   "When true, COMPILE-FILE will display the name of the file being compiled.") 

(DEFMACRO COMPILER:COMPILER-WARNINGS-CONTEXT-BIND (&BODY COMPILER::BODY)
  "Bind some variables used for compiler warnings."
  (LET ((COMPILER::TOP-LEVEL-P-VAR (GENSYM)))
    `(LET ((,COMPILER::TOP-LEVEL-P-VAR (NOT COMPILER::COMPILER-WARNINGS-CONTEXT)))
       (LET-IF ,COMPILER::TOP-LEVEL-P-VAR
	  ((COMPILER::COMPILER-WARNINGS-CONTEXT T) (COMPILER::FUNCTIONS-REFERENCED NIL))
	  (MULTIPLE-VALUE-PROG1 (PROGN
				  . ,COMPILER::BODY)
	     (COND
	       (,COMPILER::TOP-LEVEL-P-VAR
		(COMPILER::PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED)))))))) 


(DEFMACRO COMMON-LISP::WITH-COMPILATION-UNIT ((&KEY (COMPILER::OVERRIDE NIL)) &BODY COMPILER::FORMS)
  "Executes FORMS in a context in which compiler warnings about references to 
undefined functions will be deferred until the end of the outermost call to 
WITH-COMPILATION-UNIT.  If OVERRIDE is true, warnings are deferred only to the 
end of this call, regardless of any outer calls."
  (IF COMPILER::OVERRIDE
    `(LET ((COMPILER::COMPILER-WARNINGS-CONTEXT T)
	   (COMPILER::FUNCTIONS-REFERENCED NIL))
       (MULTIPLE-VALUE-PROG1 (PROGN
			       . ,COMPILER::FORMS)
	  (COMPILER::PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED)))
    `(COMPILER:COMPILER-WARNINGS-CONTEXT-BIND . ,COMPILER::FORMS))) 


(DEFVAR COMMON-LISP::*COMPILE-FILE-TRUENAME* NIL
   "Bound by COMPILE-FILE to the truename of the file being compiled.") 


(DEFVAR COMMON-LISP::*COMPILE-FILE-PATHNAME* NIL
   "Bound by COMPILE-FILE to the pathname being compiled.") 


(DEFVAR COMPILER::SOURCE-FORM NIL) 

(DEFUN COMPILER::COMPILER-WARM-BOOT NIL
  (DEALLOCATE-WHOLE-RESOURCE 'COMPILER::COMPILER-TEMPS-RESOURCE)
  (SETQ COMPILER::QCOMPILE-TEMPORARY-AREA NIL)
  (SETQ COMPILER::COMPILER-QUEUE NIL)
  (SETQ COMPILER::COMPILER-WARNINGS-CONTEXT NIL)
  (SETQ ERROR-MESSAGE-HOOK NIL)
  (SETQ SYS:FILE-IN-COLD-LOAD NIL)
  (LOCALLY
   (DECLARE
    (SPECIAL COMPILER::1-IF-LIVE-CODE COMPILER::DONT-PROPAGATE-INTO-LOOP
       COMPILER::*OVERLAP-CANDIDATES*))
   (SETQ COMPILER::1-IF-LIVE-CODE 1) (SETQ COMPILER::DONT-PROPAGATE-INTO-LOOP 0)
     (SETQ COMPILER::*OVERLAP-CANDIDATES* T))
  (SETQ COMPILER::WARN-CATCHER NIL)
  (SETQ COMPILER::QC-FILE-IN-PROGRESS NIL)
  (SETQ SYS:UNDO-DECLARATIONS-FLAG NIL)
  (SETQ COMPILER::QC-FILE-READ-IN-PROGRESS NIL)
  (SETQ LOCAL-DECLARATIONS NIL)
  (SETQ COMPILER::FILE-SPECIAL-LIST NIL
	COMPILER::FILE-UNSPECIAL-LIST NIL)
  (SETQ COMPILER::FILE-CONSTANTS-LIST NIL)
  (SETQ COMPILER::INLINE-DECLARATIONS NIL)
  (SETQ SYS:FILE-LOCAL-DECLARATIONS NIL)
  (SETQ COMPILER::OPTIMIZE-SWITCH (COMPILER::MAKE-OPTIMIZE-SWITCHES))
  NIL
  (SETQ COMPILER::QC-FILE-LOAD-FLAG T)
  (SETQ COMPILER::QC-FILE-RECORD-MACROS-EXPANDED NIL)
  (SET 'COMPILER:FASD-TARGET COMPILER::HOST-PROCESSOR)
  (WHEN (FBOUNDP 'SYS::WARNINGS-WARM-BOOT)
    (SYS::WARNINGS-WARM-BOOT))
  (SETQ COMPILER:*LOCAL-ENVIRONMENT* NIL
	COMPILER:*COMPILE-FILE-ENVIRONMENT* NIL)
  (SETQ SYS::*INTERPRETER-EXTRA-ENVIRONMENT* NIL)
  (SETQ COMPILER::ERROR-WARNING-ARGS NIL)
  (SETQ COMMON-LISP::*COMPILE-FILE-TRUENAME* NIL
	COMMON-LISP::*COMPILE-FILE-PATHNAME* NIL)
  (SETQ COMPILER::CHECK-CONFORMANCE NIL
	COMPILER::SOURCE-FORM NIL)
  NIL)

(DEFMACRO COMPILER::WITH-WARNINGS-HANDLER (&BODY COMPILER::BODY)
  `(CONDITION-BIND ((CLEH:WARNING 'COMPILER::COMPILER-WARNING-HANDLER)) ,@COMPILER::BODY)) 


(DEFUN COMPILER::COMPILER-WARNING-HANDLER (CONDITION)
  (COMPILER:WARN 'COMPILER::COMPILER-WARNING-HANDLER ':IMPLAUSIBLE "Warning: ~A" CONDITION)
  (IGNORE-ERRORS (CLEH:MUFFLE-WARNING))
  NIL) 


))


#!C
; From file INITIAL-LISP-SYMBOLS.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SI:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SI:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; INITIAL-LISP-SYMBOLS.É#É"



;;;  The COMMON-LISP package contains the symbols that are part of the
;;;  forthcoming ANSI Common Lisp standard.  It includes the symbols in
;;;  the list above except for those in *NONSTANDARD-SYMBOLS*, plus the
;;;  symbols in *ANSI-SYMBOLS*.

(defconstant *ANSI-SYMBOLS* ; symbols in CL but not in LISP
      '(;; Symbols from chapters 1 and 2 of the CLOS spec [88-002R]:
	clos:ADD-METHOD
	clos:BUILT-IN-CLASS
	clos:CALL-METHOD clos:CALL-NEXT-METHOD  clos:CHANGE-CLASS clos:CLASS-NAME
	clos:CLASS-OF  clos:COMPUTE-APPLICABLE-METHODS
	clos:DEFCLASS clos:DEFGENERIC clos:DEFINE-METHOD-COMBINATION clos:DEFMETHOD
	clos:ENSURE-GENERIC-FUNCTION
	clos:FIND-CLASS clos:FIND-METHOD clos:FUNCTION-KEYWORDS
	clos:GENERIC-FLET clos:GENERIC-FUNCTION clos:GENERIC-LABELS
	clos:INITIALIZE-INSTANCE clos:INVALID-METHOD-ERROR
	clos:MAKE-INSTANCE clos:MAKE-INSTANCES-OBSOLETE clos:MAKE-METHOD
	clos:METHOD-COMBINATION
	clos:METHOD-COMBINATION-ERROR clos:METHOD-QUALIFIERS 
	clos:NEXT-METHOD-P clos:NO-APPLICABLE-METHOD clos:NO-NEXT-METHOD
	clos:PRINT-OBJECT
	clos:REINITIALIZE-INSTANCE clos:REMOVE-METHOD
	clos:SHARED-INITIALIZE
	clos:SLOT-BOUNDP clos:SLOT-EXISTS-P clos:SLOT-MAKUNBOUND clos:SLOT-MISSING 
	clos:SLOT-UNBOUND clos:SLOT-VALUE
	clos:STANDARD clos:STANDARD-CLASS clos:STANDARD-GENERIC-FUNCTION
	clos:STANDARD-METHOD clos:STANDARD-OBJECT clos:STRUCTURE-CLASS clos:SYMBOL-MACROLET
	clos:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS clos:UPDATE-INSTANCE-FOR-REDEFINED-CLASS
	clos:WITH-ADDED-METHODS clos:WITH-SLOTS clos:WITH-ACCESSORS

	;; More CLOS symbols added to the draft standard:
	clos:CLASS
	clos:DESCRIBE-OBJECT
	clos:MAKE-LOAD-FORM clos:MAKE-LOAD-FORM-SAVING-SLOTS

	;; other new features in the standard
	CL:*COMPILE-VERBOSE*
	CL:*COMPILE-PRINT*
	SYS:*GENSYM-COUNTER*
	;; sys:*GENSYM-PREFIX* ; removed 10/12/89, this was a mistake in 6.0
	CL:COMPLEMENT		
	CL:CONSTANTLY		
	CL:DEBUG
	CL:DEFPACKAGE ; changed from TICL:DEFPACKAGE 10/27/89
	TICL:DESTRUCTURING-BIND
	CL:DYNAMIC-EXTENT
	TICL:FDEFINITION
	CL:FUNCTION-LAMBDA-EXPRESSION
	CL:LOAD-TIME-VALUE
	TICL:NTH-VALUE
	CL:OPEN-STREAM-P
	TICL:REAL
	TICL:REALP
	CL:STYLE-WARNING
	CL:UPGRADED-ARRAY-ELEMENT-TYPE
	CL:BASE-CHARACTER
	CL:EXTENDED-CHARACTER
	CL:BASE-STRING
	CL:SIMPLE-BASE-STRING
	
	;; Adopted at the June 1989 meeting of X3J13
	cl:WITH-STANDARD-IO-SYNTAX CL:*READ-EVAL* CL:*PRINT-READABLY*
	cl:PRINT-UNREADABLE-OBJECT
	cl:MAP-INTO
	FS:LOGICAL-PATHNAME cl:TRANSLATE-LOGICAL-PATHNAME
	cl:LOGICAL-PATHNAME-TRANSLATIONS cl:LOAD-LOGICAL-PATHNAME-TRANSLATIONS
	cl:COMPILE-FILE-PATHNAME
	cl:WILD-PATHNAME-P cl:PATHNAME-MATCH-P cl:TRANSLATE-PATHNAME
	cl:INTERACTIVE-STREAM-P
	cl:DECLAIM
	cl:DECLARATION-INFORMATION cl:PARSE-MACRO cl:ENCLOSE
	cl:FILE-STRING-LENGTH
	cl:DEFINE-COMPILER-MACRO cl:COMPILER-MACRO-FUNCTION

	;; Common Lisp Condition System
	cleh::*BREAK-ON-SIGNALS* cleh::*DEBUGGER-HOOK* cleh::ABORT cleh::ARITHMETIC-ERROR
	cleh::ARITHMETIC-ERROR-OPERANDS cleh::ARITHMETIC-ERROR-OPERATION cleh::ASSERT cleh::BREAK
	cleh::CCASE cleh::CELL-ERROR cleh::CELL-ERROR-NAME cleh::CERROR cleh::CHECK-TYPE
	cleh::COMPUTE-RESTARTS CONDITION cleh::CONTINUE cleh::CONTROL-ERROR cleh::CTYPECASE
	cleh::DEFINE-CONDITION cleh::DIVISION-BY-ZERO cleh::ECASE cleh::END-OF-FILE cleh::ERROR
	cleh::ETYPECASE cleh::FILE-ERROR cleh::FILE-ERROR-PATHNAME cleh::FIND-RESTART
	cleh::FLOATING-POINT-OVERFLOW cleh::FLOATING-POINT-UNDERFLOW cleh::HANDLER-BIND
	cleh::HANDLER-CASE cleh::IGNORE-ERRORS cleh::INVOKE-DEBUGGER cleh::INVOKE-RESTART
	cleh::INVOKE-RESTART-INTERACTIVELY cleh::MAKE-CONDITION cleh::MUFFLE-WARNING
	cleh::PACKAGE-ERROR cleh::PACKAGE-ERROR-PACKAGE cleh::PROGRAM-ERROR cleh::RESTART
	cleh::RESTART-BIND cleh::RESTART-CASE cleh::RESTART-NAME cleh::SERIOUS-CONDITION cleh::SIGNAL
	cleh::SIMPLE-CONDITION cleh::SIMPLE-CONDITION-FORMAT-ARGUMENTS
	cleh::SIMPLE-CONDITION-FORMAT-STRING cleh::SIMPLE-ERROR cleh::SIMPLE-TYPE-ERROR
	cleh::SIMPLE-WARNING cleh::STACK-OVERFLOW cleh::STORAGE-CONDITION cleh::STORAGE-EXHAUSTED
	cleh::STORE-VALUE cleh::STREAM-ERROR cleh::STREAM-ERROR-STREAM cleh::TYPE-ERROR
	cleh::TYPE-ERROR-DATUM cleh::TYPE-ERROR-EXPECTED-TYPE cleh::UNBOUND-VARIABLE
	cleh::UNDEFINED-FUNCTION cleh::USE-VALUE cleh::WARN cleh::WARNING cleh::WITH-SIMPLE-RESTART

	;; features with different implementions in LISP and CL
	CL:FIND-SYMBOL
	CL:INTERN
	CL:GENSYM
	CL:STRUCTURE ; only used as DOCUMENTATION key; TICL:STRUCTURE is also a type specifier.
	CL:GET

	;; More new things in the standard that we don't actually support yet
	CL:*COMPILE-FILE-PATHNAME*
	CL:*COMPILE-FILE-TRUENAME*
	CL:*LOAD-PATHNAME*
	CL:*LOAD-PRINT*
	CL:*LOAD-TRUENAME*
	CL:*PRINT-LINES*
	CL:*PRINT-MISER-WIDTH*
	CL:*PRINT-PPRINT-DISPATCH*
	CL:*PRINT-RIGHT-MARGIN*
	CL:AUGMENT-ENVIRONMENT
	CL:BROADCAST-STREAM
	CL:BROADCAST-STREAM-STREAMS
	CL:COMPILER-MACROEXPAND
	CL:COMPILER-MACROEXPAND-1
	CL:CONCATENATED-STREAM
	CL:CONCATENATED-STREAM-STREAMS
	CL:COPY-PPRINT-DISPATCH
	CL:DEFDECLARE
	CL:ECHO-STREAM
	CL:ECHO-STREAM-INPUT-STREAM
	CL:ECHO-STREAM-OUTPUT-STREAM
	CL:FILE-STREAM
	CL:FORMATTER
	CL:FUNCTION-INFORMATION
	CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT
	CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
	CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT
	CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT
	CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT
	CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
	CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT
	CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT
	CL:LOOP-FINISH
	CL:PPRINT-DISPATCH
	CL:PPRINT-FILL
	CL:PPRINT-INDENT
	CL:PPRINT-LINEAR
	CL:PPRINT-LOGICAL-BLOCK
	CL:PPRINT-NEWLINE
	CL:PPRINT-POP
	CL:PPRINT-TAB
	CL:PPRINT-TABULAR
	CL:PRINT-NOT-READABLE
	CL:PRINT-NOT-READABLE-OBJECT
	CL:READTABLE-CASE
	CL:SET-PPRINT-DISPATCH
	CL:STREAM-EXTERNAL-FORMAT
	CL:STRING-STREAM
	CL:SYNONYM-STREAM
	CL:SYNONYM-STREAM-SYMBOL
	CL:TWO-WAY-STREAM
	CL:TWO-WAY-STREAM-INPUT-STREAM
	CL:TWO-WAY-STREAM-OUTPUT-STREAM
	CL:UNBOUND-SLOT
	CL:UNBOUND-SLOT-INSTANCE
	CL:UPGRADED-COMPLEX-PART-TYPE
	CL:VARIABLE-INFORMATION
	CL:WITH-COMPILATION-UNIT
	CL:WITH-CONDITION-RESTARTS
	CL:WITH-HASH-TABLE-ITERATOR
	CL:WITH-PACKAGE-ITERATOR
	))

(defconstant *NONSTANDARD-SYMBOLS* ; symbols in LISP but not in CL
      '(;; features removed from the standard
	COMMON
	COMMONP
	COMPILER-LET
	PROVIDE
	REQUIRE
	*MODULES*
	CHAR-FONT-LIMIT
	CHAR-BITS-LIMIT
	INT-CHAR
	CHAR-BITS
	CHAR-FONT
	MAKE-CHAR
	CHAR-CONTROL-BIT
	CHAR-META-BIT
	CHAR-SUPER-BIT
	CHAR-HYPER-BIT
	CHAR-BIT
	SET-CHAR-BIT
	STRING-CHAR STRING-CHAR-P ; removed by character committee issue 2.1.2.
	*BREAK-ON-WARNINGS* ; removed 10/12/89

	;; features with different implementions in LISP and CL
	FIND-SYMBOL
	GENSYM
	INTERN
	GET
	BREAK ERROR CERROR SIGNAL MAKE-CONDITION IGNORE-ERRORS WARN
	CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE
	))

))





#!C
; From file file.LISP#> KERNEL; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; FILE.É#É"

(EVAL-WHEN (EVAL COMPILE)
  (UNLESS (FBOUNDP 'SYS:SCHEME-ON-P)
    ;; The official definition of this is in "SYS:PUBLIC.SCHEME;MODE".
    SYS:
    (DEFSUBST SCHEME-ON-P (&OPTIONAL GLOBALLY)
      "Returns true if the current Lisp Mode is :SCHEME and returns false otherwise.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are checked."
      (IF GLOBALLY
	  (EQ (SYMEVAL-GLOBALLY '*LISP-MODE*) :SCHEME)
	(EQ *LISP-MODE* :SCHEME)))))


(DEFUN compiler:COMPILE-FILE (&OPTIONAL INPUT-FILENAME
		     &KEY OUTPUT-FILE LOAD
		     SET-DEFAULT-PATHNAME
		     (VERBOSE COMPILER-VERBOSE VERBOSE-SUPPLIED)
		     TARGET DECLARE
		     ((:PACKAGE PACKAGE-SPEC))
		     ((:SUPPRESS-DEBUG-INFO *SUPPRESS-DEBUG-INFO*) *SUPPRESS-DEBUG-INFO*)
		     (CONFORMANCE NIL CP)
		     #+compiler:debug MERCILESS
		     )
  "Compile source file INPUT-FILE to an object file named OUTPUT-FILE.
OUTPUT-FILE defaults based on INPUT-FILE, which defaults using the
FS:LOAD-PATHNAME-DEFAULTS.  Additional optional arguments are:
  :LOAD if true means to load the output file after compiling.
  :VERBOSE if true means to print the name of each function as it is compiled.
  :DECLARE is a list of declaration specifiers.
  :SET-DEFAULT-PATHNAME if true means to set the default pathname.
  :PACKAGE is the package to compile in.
  :SUPPRESS-DEBUG-INFO if true discards debugging information and documentation
     strings of functions whose names are not EXPORTed.
  :CONFORMANCE if true causes warnings to be issued for use of Explorer 
     extensions to standard Common Lisp.
Two values are returned; the first is the output file pathname and the
second is a status code equal to one of the following constants:
COMPILER:OK, COMPILER:WARNINGS, COMPILER:ERRORS, or COMPILER:FATAL."
;; :TARGET is the name of the machine for which code will be generated.

  ;;  2/01/86 - Added option :SUPPRESS-DEBUG-INFO.
  ;;  3/14/86 - Added option :MERCILESS to suppress defaulting target
  ;;		definitions from the host environment.
  ;; 10/30/89 DNG - Added :CONFORMANCE option.
  (DECLARE (ARGLIST INPUT-FILE &KEY :OUTPUT-FILE :LOAD :VERBOSE
	       :SET-DEFAULT-PATHNAME :PACKAGE :DECLARE :CONFORMANCE
	       #+compiler:debug :TARGET
	       :SUPPRESS-DEBUG-INFO 
	       #+compiler:debug :MERCILESS ))
  (DECLARE (VALUES OUTPUT-FILE ERROR-STATUS))
  (UNLESS (NULL TARGET)
    (SETQ TARGET (VALIDATE-TARGET TARGET T)) )
  (MULTIPLE-VALUE-BIND ( OUTFILE STATUS )
      (LET (( COMPILER-VERBOSE VERBOSE )
	    ( DECLARATION-LIST (IF (OR (NULL DECLARE) (CONSP (FIRST DECLARE)))
				   DECLARE	; list of declaration specifiers
				 (LIST DECLARE)) )	; make list from single specifier
	    #+compiler:debug
	    ( *DEFAULT-DEFS-FROM-HOST* (NOT MERCILESS) ))
       (LET-IF CP ((*CONFORMANCE* CONFORMANCE))
	(COND #+false ; superseded by use of NO-OUTPUT . #+compiler:debug
	      ((keywordp output-file)
	       (let-unless-constant (( target-processor (or target host-processor) ))
		 (qc-file-mem input-filename package-spec declaration-list (not set-default-pathname))))
	      (T (INHIBIT-STYLE-WARNINGS
		   (QC-FILE (OR INPUT-FILENAME "") OUTPUT-FILE
			  NIL NIL PACKAGE-SPEC
			  DECLARATION-LIST
			  (NOT SET-DEFAULT-PATHNAME)
			  NIL
			  TARGET)) ))) )
    (WHEN (AND LOAD (< STATUS FATAL))
      (IF VERBOSE-SUPPLIED
	  (LOAD OUTFILE :VERBOSE VERBOSE)
	(LOAD OUTFILE)))
    (VALUES OUTFILE STATUS) ) )




(DEFPARAMETER COMPILER::NO-OUTPUT ':NONE) 


(eval-when (eval compile load)
  (DEFFLAVOR COMPILER::DUMMY-PATHNAME NIL (PATHNAME))
  (DEFMETHOD (COMPILER::DUMMY-PATHNAME :PARSE-NAMESTRING) IGNORE) 
  (DEFMETHOD (COMPILER::DUMMY-PATHNAME :PRINT-SELF) (STREAM &REST IGNORE)
    (WRITE-STRING "#<DUMMY-PATHNAME>" STREAM)) 
  (DEFMETHOD (COMPILER::DUMMY-PATHNAME :TRUENAME) NIL
    SELF)
  )


(DEFUN compiler:QC-FILE (INFILE &OPTIONAL OUTFILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC
				 FILE-LOCAL-DECLARATIONS
				 DONT-SET-DEFAULT-P
				 IGNORE ; used to be READ-THEN-PROCESS-FLAG
				 #.(IF (GET-FOR-TARGET 'TARGET-PROCESSOR 'SYSTEM-CONSTANT)
				       'IGNORE
				     'TARGET-PROCESSOR)
		       &AUX GENERIC-PATHNAME
			    QC-FILE-MACROS-EXPANDED
			    (QC-FILE-RECORD-MACROS-EXPANDED T)
			    ( DECLARATIONS-IGNORED DECLARATIONS-IGNORED )
			    ( INLINE-DECLARATIONS INLINE-DECLARATIONS )
			    ( *RETURN-STATUS* OK )
			    ( SI:FDEFINE-FILE-DEFINITIONS NIL ))
  "Compile Lisp source file INFILE, producing a binary file and calling it OUTFILE.
PACKAGE-SPEC specifies which package to read the source in
\(usually the file's attribute list provides the right default).
LOAD-FLAG and IN-CORE-FLAG are semi-losing features; leave them NIL."
  ;; 1/25/85 DNG - Fix target file type.
  ;; 2/05/85 DNG - Modify target processor handling to allow different *FEATURES*
  ;;		   list for Lambda and Cadr.
  ;; 9/17/85 DNG - Use new function PROCESSOR-TYPE-FOR-FILE.
  ;; 1/14/86 DNG - Fix merging of output pathname to always have correct
  ;;		   type and version:
  ;;		      * Never write a ".LISP" file.
  ;;		      * Supersede the same version as the input file if the name
  ;;			of the output file is the same as that of the input file.
  ;;		      * If a different name is specified for the output, or if
  ;;			the output explicitely specifies "#>", then
  ;;			write a new version one greater than the last version.
  ;; 1/31/86 DNG - Bind SI:FDEFINE-FILE-DEFINITIONS to NIL so it doesn't accumulate
  ;;		   pointers into the compiler temporary area.
  ;; 3/03/86 DNG - When cross-compiling, ADVISE FDEFINE so that functions definitions
  ;;		within an (EVAL-WHEN (COMPILE) ...) are defined in the target envirionment.
  ;; 5/29/86 DNG - Modified to work when TARGET-PROCESSOR is a constant.
  ;; 6/18/86 DNG - Modify to work when SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE is not defined.
  ;; 9/04/86 DNG - Use new function MERGE-PATHNAMES-WITH-NEW-TYPE;
  ;; 		return the :TRUENAME of the output stream instead of the :PATHNAME.
  ;; 9/05/86 DNG - Give warning on missing attributes. [SPR 1165]
  ;;11/21/86 DNG - Remove call to SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE which no
  ;;		longer exists in release 3.  Use ZETA-C:C-COMPILE-FILE for ".c" files.
  ;;		Delete binding of SI:INTERPRETER-DECLARATION-TYPE-ALIST.
  ;; 2/09/87 DNG - Modify test for missing file attributes.
  ;; 3/02/87 DNG - BIND interpreter environment to NIL since not done by file attribute bindings anymore.
  ;; 3/07/87 DNG - Modify test for missing file attributes again to try to keep up with FS changes.
  ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
  ;;10/26/88 DNG - Add binding of *COMPILE-FILE-ENVIRONMENT* and call CLEAN-UP-ENVIRONMENT.
  ;;10/31/88 DNG - Add binding of *LOCAL-ENVIRONMENT* so it has the correct 
  ;;		value when COMPILE-STREAM calls PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED.
  ;;11/03/88 DNG - Add an UNWIND-PROTECT to ensure that CLEAN-UP-ENVIRONMENT is called.
  ;; 4/12/89 DNG - Add setting of ENV-GLOBAL-ENV.
  ;;10/30/89 DNG - Add use of *COMPILE-VERBOSE*.
  ;;11/03/89 DNG - Add option to suppress writing an object file.

  (DECLARE (VALUES OUTFILE STATUS))
 (record-individual-time 'qc-file
  (WHEN-SUPPORTING-CROSS-COMPILATION
    (WHEN (NULL TARGET-PROCESSOR)
      (SETQ TARGET-PROCESSOR HOST-PROCESSOR)))
  ;; Default the specified input and output file names.  Open files.
  (SETQ INFILE (FS:MERGE-PATHNAME-DEFAULTS INFILE FS:LOAD-PATHNAME-DEFAULTS NIL))
  (WHEN (EQ (SEND INFILE :CANONICAL-TYPE) :C)
    (LET ((X (FIND-PACKAGE "ZETA-C")))
      (UNLESS (NULL X)
	(LET ((*PACKAGE* (IF PACKAGE-SPEC (PKG-FIND-PACKAGE PACKAGE-SPEC) *PACKAGE*)))
	  (RETURN-FROM QC-FILE (VALUES (FUNCALL (INTERN "C-COMPILE-FILE" X) INFILE) OK))))))
  (WITH-OPEN-STREAM (INPUT-STREAM
		      (FILE-RETRY-NEW-PATHNAME (INFILE FS:FILE-ERROR)
			(SEND INFILE :OPEN-CANONICAL-DEFAULT-TYPE ':LISP)))
    ;; The input pathname might have been changed by the user in response to an error.
    ;; Also, find out what type field was actually found.
    (SETQ INFILE (SEND INPUT-STREAM :PATHNAME))
    (OR DONT-SET-DEFAULT-P (FS:SET-DEFAULT-PATHNAME INFILE FS:LOAD-PATHNAME-DEFAULTS))
    (SETQ GENERIC-PATHNAME (SEND INFILE :GENERIC-PATHNAME))
    (UNLESS (EQ OUTFILE NO-OUTPUT)
      (SETQ OUTFILE
	    (MERGE-PATHNAMES-WITH-NEW-TYPE
	      INFILE INPUT-STREAM OUTFILE
	      (TARGET-BINARY-FILE-TYPE TARGET-PROCESSOR)))
      (WHEN-SUPPORTING-CROSS-COMPILATION
	(SETQ TARGET-PROCESSOR (PROCESSOR-TYPE-FOR-FILE OUTFILE))))
    ;; Get the file property list again, in case we don't have it already or it changed
    (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME INPUT-STREAM)
    ;; Bind all the variables required by the file property list.
    (MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME)
      (DECLARE (UNSPECIAL VARS))
      (UNLESS (OR (AND (NULL VARS) (COMMON-LISP-ON-P))
		  (MEMBER ':COMMON-LISP VALS)) ; Common Lisp doesn't require an attribute line
	(DOLIST (X '((SI:*LISP-MODE* "Mode")
		     (*PACKAGE* "Package")
		     (*READ-BASE* "Base")))
	  (UNLESS (OR (MEMBER (FIRST X) VARS :TEST #'EQ)
		      (AND (EQ (FIRST X) '*PACKAGE*) PACKAGE-SPEC))
	    (FORMAT T "~&~A not specified; assuming ~A." (SECOND X) (SYMBOL-VALUE (FIRST X))))))
      (PROGV VARS VALS
	(LET* (( TARGET-FEATURES
		(COND ((EQ TARGET-PROCESSOR HOST-PROCESSOR) NIL)
		      ((AND (EQ HOST-PROCESSOR ':EXPLORER)
			    (MEMBER TARGET-PROCESSOR '(:CLM :ELROY :JUDY) :TEST #'EQ))
		       (LIST* TARGET-PROCESSOR :IEEE-FLOATING-POINT *FEATURES*) )
		      (T (CONS TARGET-PROCESSOR
			       (SET-DIFFERENCE *FEATURES*
					       '(:EXPLORER :CADR :LAMBDA)))) ))
	      (SI:*INTERPRETER-ENVIRONMENT* NIL)
	      (SI:*INTERPRETER-FUNCTION-ENVIRONMENT* NIL)
	      ;; Uncomment the next line if cross-compilation is ever re-enabled.
	      ;;(*TARGET-ENVIRONMENT* (ENSURE-TARGET-ENVIRONMENT TARGET-PROCESSOR))
	      (*COMPILE-FILE-ENVIRONMENT* (EXTEND-ENVIRONMENT :PARENT *TARGET-ENVIRONMENT*))
	      (*LOCAL-ENVIRONMENT* *COMPILE-FILE-ENVIRONMENT*))
	(SETF (ENV-GLOBAL-ENV *COMPILE-FILE-ENVIRONMENT*) *COMPILE-FILE-ENVIRONMENT*)
	(WHEN-SUPPORTING-CROSS-COMPILATION
	  (WHEN (EQ TARGET-PROCESSOR ':LAMBDA)
	    ;; Lambda and Cadr are different only in the features list.
	    (SETQ TARGET-PROCESSOR ':CADR) ))
	(UNWIND-PROTECT
	   (IF (EQ OUTFILE NO-OUTPUT) ; just do error checking, no output file.
	       (LET ((FASD-STREAM NIL))
		 (SETQ OUTFILE '#,(MAKE-INSTANCE 'DUMMY-PATHNAME :HOST NIL
						 :NAME (SYMBOL-NAME 'NULL) :VERSION :UNSPECIFIC))
		 (LOCKING-RESOURCES-NO-QFASL
		   (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME NIL
				   #'(LAMBDA (FORM)
				       (LET ((DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA))
					 (COMPILE-DRIVER FORM
							 #'(LAMBDA (FORM TYPE)
							     (QC-FILE-COMMON FORM TYPE 'CHECK-ONLY #'IGNORE))
							 NIL)))
				   LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC
				   FILE-LOCAL-DECLARATIONS NIL
				   T)))
	     (WITH-OPEN-FILE (FASD-STREAM OUTFILE
				:DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16.
				:IF-EXISTS (IF (NUMBERP (SEND OUTFILE :VERSION))
					       :SUPERSEDE
					     :NEW-VERSION))
		 (LOCKING-RESOURCES
		   (SETQ OUTFILE (SEND FASD-STREAM :TRUENAME))
		   (WHEN *COMPILE-VERBOSE*
		     (FORMAT T "~&; Compiling file \"~A\" to \"~A\"."
			     (SEND INPUT-STREAM :TRUENAME) OUTFILE))
		   (FASD-INITIALIZE)
		   (FASD-START-FILE)
		   (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		       (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM
				       #'QC-FILE-WORK-COMPILE
				       LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC
				       FILE-LOCAL-DECLARATIONS NIL
				       T)
		     (UNWIND-PROTECT
			 (LET (( *POSSIBLE-SPECIAL-BINDINGS* NIL ))
			   (ADVISE FDEFINE :AROUND LOAD-FOR-TARGET NIL
			     (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
				     (EQ (CAR-SAFE (FIRST ARGLIST)) ':TARGET))
				 :DO-IT 
			       (APPLY #'CROSS-LOAD-FDEFINE ARGLIST) ) )
			   (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM
					   #'QC-FILE-WORK-COMPILE
					   LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC
					   FILE-LOCAL-DECLARATIONS NIL
					   T) )
		       (UNADVISE FDEFINE :AROUND LOAD-FOR-TARGET) ) )
		   ;; Output a record of the macros expanded and their current sxhashes.
		   (WHEN QC-FILE-MACROS-EXPANDED
		     (FASD-FORM
		       `(SI:FASL-RECORD-FILE-MACROS-EXPANDED
			  ',QC-FILE-MACROS-EXPANDED)))
		   (FASD-END-WHACK)
		   (FASD-END-FILE))))
	(CLEAN-UP-ENVIRONMENT *COMPILE-FILE-ENVIRONMENT*))
	))))
  )
  (VALUES OUTFILE *RETURN-STATUS*) ) 

(defun cl:COMPILE-FILE-PATHNAME (pathname &key output-file
				 &extension LOAD SET-DEFAULT-PATHNAME
				 VERBOSE TARGET DECLARE PACKAGE SUPPRESS-DEBUG-INFO CONFORMANCE)
  "Returns the pathname that COMPILE-FILE would write into, if given the
same arguments.  If the PATHNAME argument is a logical pathname and the
:OUTPUT-FILE argument is unspecified, the result is a logical pathname."
  ;;  7/11/89 DNG - Original.
  ;; 10/27/89 DNG - Moved to here from file "KERNEL;ANSI".
  ;; 10/30/89 DNG - Accept new :CONFORMANCE option.
  (declare (ignore LOAD SET-DEFAULT-PATHNAME VERBOSE DECLARE PACKAGE 
		   SUPPRESS-DEBUG-INFO CONFORMANCE))
  (let ((infile (FS:MERGE-PATHNAME-DEFAULTS pathname FS:LOAD-PATHNAME-DEFAULTS NIL)))
    (MERGE-PATHNAMES-WITH-NEW-TYPE
      infile (or (probe-file infile)
		 #'(lambda (ignore) ; used only for :TRUENAME operation
		     '#,(make-pathname :host "SYS" :version :newest)))
      output-file
      (target-binary-file-type (validate-target target)))))
 


(DEFUN (:PROPERTY :CONFORMANCE FS:FILE-ATTRIBUTE-BINDINGS) (IGNORE IGNORE VAL)
  (VALUES (CONS '*CONFORMANCE* '()) (CONS VAL '()))) 


(DEFUN COMPILE-STREAM (INPUT-STREAM GENERIC-PATHNAME FASD-FLAG PROCESS-FN
		       QC-FILE-LOAD-FLAG QC-FILE-IN-CORE-FLAG PACKAGE-SPEC
		       &OPTIONAL (FILE-LOCAL-DECLARATIONS NIL)
		       IGNORE ; used to be READ-THEN-PROCESS-FLAG
		       COMPILING-WHOLE-FILE-P OPERATION-TYPE)
  "This function does all the \"outer loop\" of the compiler, for file and editor compilation.
Expressions to be compiled are read from INPUT-STREAM.
The caller is responsible for handling any file attributes.
GENERIC-PATHNAME is the file to record information for and use the attributes of.
 It may be NIL if compiling to core.
FASD-FLAG is NIL if not making an object file.
PROCESS-FN is called on each form.
QC-FILE-LOAD-FLAG, QC-FILE-IN-CORE-FLAG, and PACKAGE-SPEC are options.
FILE-LOCAL-DECLARATIONS is normally initialized to NIL,
but you can optionally pass in an initializations for it.
COMPILING-WHOLE-FILE-P should be T if you are processing all of the file."
  ;;  2/23/85 - Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP .
  ;;  2/27/85 - Record version number of the "Compiler" sub-system in the object file.
  ;;  2/28/85 - Test for starting new whack moved from here to QC-FILE-COMMON. [SPR 804]
  ;;		Record outside value of OPTIMIZE switches in the object file.
  ;;  1/31/86 - Push pathname onto COLD-LOAD-FILES if it has COLD-LOAD attribute.
  ;;  4/24/86 - Set *LAST-ADDRESS-READ*.
  ;;  4/25/86 - Fix to use GLOBAL:READ instead of CLI:READ.
  ;;  6/18/86 - Modify to work when SI:GET-SYSTEM-VERSION is not defined.
  ;;  6/30/86 - Record the system name in the object file if different from "SYSTEM".
  ;;  8/08/86 - Use macro WITH-COMPILE-DRIVER-BINDINGS.
  ;;  9/11/86 - Warn when in Zetalisp mode but not using the ZLC package.
  ;;  9/26/86 - Check QC-FILE-CHECK-INDENTATION at each read instead of only at the
  ;;		beginning so that it can be changed within the file.
  ;;		When compiling in memory, read into a write-protected area. [SPR 405]
  ;; 10/08/86 - Suppress "end of data" messages in Eval Buffer. [SPR 1041]
  ;;  2/07/87 - Remove use of write-protected area for reading -- it was causing
  ;;		more problems than it was solving.
  ;;  3/20/87 - Fix to not warn about not using ZLC package when GLOBAL is being used instead.
  ;;  7/22/87 - Read in SOURCE-CODE-AREA in QC-FILE as well as Compile Buffer;
  ;;		eliminate use of *LAST-ADDRESS-READ*.
  ;;  4/13/88 DNG - Re-instate test for starting a new whack here as well as 
  ;;		in QC-FILE-COMMON in order to preferentially break between
  ;;		top-level forms. [SPR 7234]
  ;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
  ;;  8/04/88 DNG - Bind SELF to NIL.
  ;;  1/03/89 DNG - Don't record font list in the object file. (Just a waste of space.)
  ;;  3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore.
  ;;  4/22/89 DNG - Include Scheme support:  Warn if in Scheme mode without using the 
  ;;		Scheme package (or in Common Lisp mode without the LISP package).  Fix 
  ;;		to expand top-level symbol defined by SCHEME:DEFINE-INTEGRABLE.
  ;; 10/27/89 DNG - Add binding of *COMPILE-FILE-PATHNAME* and *COMPILE-FILE-TRUENAME*.
  ;; 10/28/89 DNG - Add use of WITH-WARNINGS-HANDLER.
  ;; 10/30/89 DNG - Fix to use PKG-FIND-PACKAGE instead of FIND-PACKAGE.
  ;; 11/03/89 DNG - Add binding and use of CHECK-CONFORMANCE.
  ;; 11/06/89 DNG - If read aborts with an error, don't recompile the previous form read.

 (record-individual-time 'compile-stream
  (LET ((*PACKAGE* *PACKAGE*)
	(*READ-BASE* *READ-BASE*) (*PRINT-BASE* *PRINT-BASE*)
	(OPTIMIZE-SWITCH OPTIMIZE-SWITCH)
	FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST
	( FILE-CONSTANTS-LIST NIL )
	( *BARF-DEFAULTS* NIL )
	( SELF NIL ) ; Prevent accidental references to the window the compiler was invoked from.
	(CL:*COMPILE-FILE-PATHNAME* NIL)
	FDEFINE-FILE-PATHNAME)
  (FILE-OPERATION-WITH-WARNINGS (GENERIC-PATHNAME
				 (OR OPERATION-TYPE ':COMPILE)
				 COMPILING-WHOLE-FILE-P)
   (COMPILER-WARNINGS-CONTEXT-BIND
     ;; Override the package if required.  It has been bound in any case.
     (WHEN PACKAGE-SPEC (SETQ *PACKAGE* (PKG-FIND-PACKAGE PACKAGE-SPEC)))
     ;; Override the generic pathname
     (SETQ FDEFINE-FILE-PATHNAME
	   (LET ((PATHNAME (AND (MEMBER ':PATHNAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ)
				(SEND INPUT-STREAM :PATHNAME))))
	     (SETQ CL:*COMPILE-FILE-PATHNAME* PATHNAME)
	     (AND PATHNAME (SEND PATHNAME :GENERIC-PATHNAME))))
     (WHEN (AND (NOT (NULL FDEFINE-FILE-PATHNAME))
		SI:FILE-IN-COLD-LOAD
		(NOT (MEMBER FDEFINE-FILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ)))
       (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))
	 ;; Let function CHECK-COLD know that this file has the :COLD-LOAD attribute.
	 (PUSH FDEFINE-FILE-PATHNAME COLD-LOAD-FILES) ) )
     ;; Having bound the variables, process the file.
     (LET ((QC-FILE-IN-PROGRESS T)
	   (UNDO-DECLARATIONS-FLAG (NOT QC-FILE-LOAD-FLAG))
	   (LOCAL-DECLARATIONS NIL)
	   (OPEN-CODE-MAP-SWITCH OPEN-CODE-MAP-SWITCH)
	   (RUN-IN-MACLISP-SWITCH RUN-IN-MACLISP-SWITCH)
	   (OBSOLETE-FUNCTION-WARNING-SWITCH OBSOLETE-FUNCTION-WARNING-SWITCH)
	   (ALL-SPECIAL-SWITCH ALL-SPECIAL-SWITCH)
	   (SOURCE-FILE-UNIQUE-ID)
	   (FASD-PACKAGE NIL)
	   (CHECK-CONFORMANCE (AND (COMMON-LISP-ON-P)
				   (PROGN (SETQ *CONFORMANCE*
						(CASE *CONFORMANCE*
						  ((:NIL NIL) NIL)
						  ((:T T) T)
						  (OTHERWISE (INTERN *CONFORMANCE* *KEYWORD-PACKAGE*))))
					  (CHECK-TYPE *CONFORMANCE* ;; may 02/01/90 Added :CLTL+CLOS
						      (MEMBER NIL T :CLTL :CLTL+CLOS :ANSI :LUCID :ALLEGRO :LISPWORKS))
					  *CONFORMANCE*)))	
	   (CL:*COMPILE-FILE-TRUENAME* (SEND INPUT-STREAM :SEND-IF-HANDLES :TRUENAME)))
       (WHEN (AND *CONFORMANCE* (NOT (COMMON-LISP-ON-P)))
	 (WARN '*CONFORMANCE* ':PROBABLE-ERROR
	       "Conformance checking requested but will not be performed because this file isn't even in Common Lisp mode."))
       ;; Process any Common Lisp declaration specifiers found in
       ;; the FILE-LOCAL-DECLARATIONS list.  The CATCH is used to
       ;; suppress warnings from PROCLAIM about unrecognized declarations
       ;; since FILE-LOCAL-DECLARATIONS list can be used for other things too.
       (LET (( WARN-CATCHER 'FILE-LOCAL-DECLARATIONS ))
	 (DOLIST ( DECL FILE-LOCAL-DECLARATIONS )
	   (CATCH WARN-CATCHER
	     (if (eq (first decl) 'def)
		 (setf (file-local-def (second decl)) (cddr decl))
               (PROCLAIM DECL)) )))

       (WHEN FASD-FLAG
	 ;; Copy all suitable file properties into the fasl file
	 ;; Suitable means those that are lambda-bound when you read in a file.
	 (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PLIST))))
	   ;; Remove unsuitable properties
	   (DO ((L (LOCF PLIST)))
	       ((NULL (CDR L)))
	     (IF (AND (NOT (NULL (GET (CADR L) 'FS:FILE-ATTRIBUTE-BINDINGS)))
		      (NOT (EQ (CADR L) ':FONTS))) ; this doesn't affect the object.
		 (SETQ L (CDDR L))
	       (RPLACD L (CDDDR L))))
	   ;; Make sure the package property is really the package compiled in
	   ;; Must load object file into same package compiled in
	   ;; On the other hand, if we did not override it
	   ;; and the attribute list has a list for the package, write that list.
	   (UNLESS (AND (NOT (ATOM (GETF PLIST :PACKAGE)))
			(STRING-EQUAL (PACKAGE-NAME *PACKAGE*)
				      (CAR (GETF PLIST ':PACKAGE))))
	     (SETF (GETF PLIST ':PACKAGE)
		   (INTERN (PACKAGE-NAME *PACKAGE*) PKG-KEYWORD-PACKAGE)))
	   ;; Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP .
	   (SETF (GETF PLIST ':MODE) (LISP-MODE))
	   (COND ((ZETALISP-ON-P)
		  (COND ((LET ((L (PACKAGE-USE-LIST *PACKAGE*)))
			   (NOT (OR (MEMBER ZETALISP-PACKAGE L :TEST #'EQ)	; uses ZLC
				    (MEMBER SI:PKG-GLOBAL-PACKAGE L :TEST #'EQ)	; uses GLOBAL
				    (EQ (FIND-SYMBOL "MEM") 'GLOBAL:MEM)	; gets the right symbols some other way
				    )))
			 (WARN ':ZETALISP ':IMPLAUSIBLE
			       "Warning: this file is in Zetalisp mode but package ~A doesn't use the ZLC package."
			       (PACKAGE-NAME *PACKAGE*)))
			;;%%% Later add test here to do automatic MAKE-SYSTEM of the
			;;%%% Zetalisp compatibility subsystem if not already loaded.
			))
		 ((si:SCHEME-ON-P)
		  (LOCALLY (DECLARE (SPECIAL SI:SCHEME-PACKAGE))
		    (UNLESS (OR (MEMBER SI:SCHEME-PACKAGE (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses SCHEME
				; or gets the right symbols some other way
				(EQ (FIND-SYMBOL "DEFINE") (FIND-SYMBOL "DEFINE" SI:SCHEME-PACKAGE)))
		      (WARN 'si:SCHEME-ON-P ':IMPLAUSIBLE
			    "Warning: this file is in Scheme mode but package ~A doesn't use the Scheme package."
			    (PACKAGE-NAME *PACKAGE*)))))
		 ((COMMON-LISP-ON-P)
		  (UNLESS (OR (MEMBER *LISP-PACKAGE* (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses LISP
			      (EQ (FIND-SYMBOL "DEFUN") 'DEFUN)) ; gets the right symbols some other way
		    (WARN 'COMMON-LISP-ON-P ':IMPLAUSIBLE
			  "Warning: this file is in Common Lisp mode but package ~A doesn't use the Lisp package."
			  (PACKAGE-NAME *PACKAGE*)))))
	   (AND INPUT-STREAM
		(MEMBER ':TRUENAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ)
		(SETQ SOURCE-FILE-UNIQUE-ID (SEND INPUT-STREAM :TRUENAME))
		(SETF (GETF PLIST ':QFASL-SOURCE-FILE-UNIQUE-ID)
		      SOURCE-FILE-UNIQUE-ID) )
	   ;; If a file is being compiled across directories, remember where the
	   ;; source really came from.
	   (AND FDEFINE-FILE-PATHNAME FASD-STREAM
		(LET ((OUTFILE (AND (MEMBER ':PATHNAME
					    (SEND FASD-STREAM :WHICH-OPERATIONS)
					    :TEST #'EQ)
				    (SEND FASD-STREAM :PATHNAME))))
		  (WHEN OUTFILE
		    (SETQ OUTFILE (SEND OUTFILE :GENERIC-PATHNAME))
		    (AND (NEQ OUTFILE FDEFINE-FILE-PATHNAME)
			 (SETF (GETF PLIST ':SOURCE-FILE-GENERIC-PATHNAME)
			       FDEFINE-FILE-PATHNAME)))))
	   (MULTIPLE-VALUE-BIND (MAJOR MINOR)
	       (AND (FBOUNDP 'SI:GET-SYSTEM-VERSION)
		    (SI:GET-SYSTEM-VERSION))
	     (SETF (GETF PLIST ':COMPILE-DATA)
		   (LIST USER-ID
			 SI:LOCAL-PRETTY-HOST-NAME
			 (AND (FBOUNDP 'TIME:GET-UNIVERSAL-TIME)
			      (TIME:GET-UNIVERSAL-TIME))
			 MAJOR MINOR
			 (LET (( PROPS NIL ))
			   (SETF (GETF PROPS 'OPTIMIZE-SWITCH)
				 OPTIMIZE-SWITCH)
			   (WHEN (FBOUNDP 'SI:GET-SYSTEM-VERSION)
			     (MULTIPLE-VALUE-BIND ( V1 V2 )
				 (SI:GET-SYSTEM-VERSION
				   (IF (EQ 'VERSION 'COMPILER:VERSION)
				       'COMPILER
				     'COMPILER2))
			       (UNLESS (NULL V1)
				 (SETF (GETF PROPS 'VERSION)
				       (LIST V1 V2) )))
			     (UNLESS (STRING-EQUAL SI:*SYSTEM-NAME* "SYSTEM")
			       (SETF (GETF PROPS 'SI:*SYSTEM-NAME*)
				     SI:*SYSTEM-NAME*)) )
			   PROPS))))
	   ;; First thing in QFASL file must be property list
	   ;; These properties wind up on the GENERIC-PATHNAME.
	   (FASD-FILE-PROPERTY-LIST PLIST)))
       (QC-PROCESS-INITIALIZE)
       (WHEN (NULL (SYMBOL-VALUE 'SOURCE-CODE-AREA))
	 (MAKE-AREA :NAME 'SOURCE-CODE-AREA :REPRESENTATION :LIST :GC :DYNAMIC))
       (WITH-COMPILE-DRIVER-BINDINGS
	(LET-IF (AND CHECK-CONFORMANCE (NOT *WARN-OF-SUPERSEDED-FUNCTIONS-P*))
		((*WARN-OF-SUPERSEDED-FUNCTIONS-P* T))
	(WITH-WARNINGS-HANDLER
        (DO ((EOF (CONS NIL NIL))
	     (FORM))
	    (NIL)
	 ;; Detect EOF by peeking ahead, and also get an error now
	 ;; if the stream is wedged.  We really want to get an error
	 ;; in that case, not make a warning.
	 (LET ((CH (SEND INPUT-STREAM :TYI)))
	   (OR CH (RETURN))
	   (SEND INPUT-STREAM :UNTYI CH))
	 (setq si:premature-warnings
	       (append si:premature-warnings si:premature-warnings-this-object))
	 (let ((si:premature-warnings nil))
	   (LET ((DEFAULT-CONS-AREA
		  (IF (OR QC-FILE-LOAD-FLAG ; Compile Buffer
			  (NOT (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA)))	; TGC on
		      SOURCE-CODE-AREA
		    QCOMPILE-TEMPORARY-AREA))
		 (WARN-ON-ERRORS-STREAM INPUT-STREAM)
		 (QC-FILE-READ-IN-PROGRESS FASD-FLAG)	   ;looked at by XR-#,-MACRO
		 (SI:*MAXIMUM-READ-BUFFER-SIZE* 256)
		 ;; Include the following after everything has been EXPORTed that should be.
		 ;;(SI:*RESTRICT-INTERNAL-SYMBOLS* T)
		 )
	    (LET-IF CHECK-CONFORMANCE
		    ((*READ-ACCEPT-EXTENSIONS* NIL)
		     (SI::*RESTRICT-INTERNAL-SYMBOLS* T))
	     (WARN-ON-ERRORS ('READ-ERROR "Error in reading")
	       (SETQ FORM '(PROGN)) ; in case of read error, don't recompile the previous form.
	       (LET-IF TARGET-FEATURES ((*FEATURES* TARGET-FEATURES))
		 (record-individual-time 'read
		   (SETQ FORM
			 (IF QC-FILE-CHECK-INDENTATION
			     (READ-CHECK-INDENTATION INPUT-STREAM EOF)
			   (READ INPUT-STREAM NIL EOF)))
		   )))) )
	   (setq si:premature-warnings-this-object si:premature-warnings))
	 (WHEN (EQ FORM EOF) (RETURN))
	 (LOOP WHILE (AND (SYMBOLP FORM) (SI:SCHEME-ON-P))
	       ;; Expand symbols defined by SCHEME:DEFINE-INTEGRABLE .
	       DO (LET ((L (GET FORM 'INTEGRABLE '|<Undefined>|)))
		    (IF (EQ L '|<Undefined>|)
			(RETURN)
		      (PROGN (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ)
			     (SETQ FORM L)))))
	 ;; Start a new whack if FASD-TABLE is getting too big.  A smaller threshold 
	 ;; is used here than in QC-FILE-COMMON because it is safer to break here
	 ;; (less likely to have gensym references spanning the boundary).  [SPR 7234]
	 (WHEN (AND FASD-FLAG
		    (>= (FASD-TABLE-LENGTH) (- QC-FILE-WHACK-THRESHOLD 1000)))
	   (FASD-END-WHACK) )
	 (IF (AND (ATOM FORM) FASD-FLAG)
	     (WARN 'ATOM-AT-TOP-LEVEL ':IMPLAUSIBLE
		   "The atom ~S appeared at top level; this will do nothing at FASLOAD time."
		   FORM)
	   (FUNCALL PROCESS-FN FORM))
	 ) ; end of DO loop
       ;; Copy MACROS-EXPANDED to QC-FILE-MACROS-EXPANDED when appropriate.
       (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED)
     ))))) ; end of COMPILER-WARNINGS-CONTEXT-BIND
   (WHEN (EQ OPERATION-TYPE ':EVAL)
     ;; When evaluating a Zmacs buffer, OBJECT-OPERATION-WITH-WARNINGS is not used,
     ;; so "end of data" messages are not meaningful, so suppress them.  [SPR 1041]
     (SETQ si:PREMATURE-WARNINGS NIL))
   ))))

 
(DEFUN compiler:QC-FILE-COMMON (FORM TYPE &OPTIONAL (LAP-MODE 'QFASL) (EVAL-FN #'QC-FILE-FASD-FORM))
  ;; 9/26/85 DNG - Fix to start a new whack when necessary. [SPR 804]
  ;;10/21/85 DNG - When the form is to be both evaluated and fasdumped,
  ;;		   do the fasdump first so that it does not assume the
  ;;		   environment created by evaluating it.  [SPR 884]
  ;; 3/03/86 DNG - Use EVAL-FOR-TARGET instead of SI:EVAL1 so that functions
  ;;		defined within an (EVAL-WHEN (COMPILE) ...) are installed in
  ;;		the target environment.
  ;; 7/28/86 DNG - Merged QC-FILE-FORM into this function.
  ;; 7/30/86 DNG - Modified to use the new function COMPILE-TOP-LEVEL-FORM.
  ;; 8/16/86 DNG - Update FASD-PACKAGE when an IN-PACKAGE form is processed.
  ;; 1/16/87 DNG - Evaluate declarations even when QC-FILE-IN-CORE-FLAG is true. [SPR 2852]
  ;; 8/16/88 clm - Changed to call FILE-LOCAL-DEF to check if there are duplicate definitions.
  ;;10/26/88 DNG - Pass *LOCAL-ENVIRONMENT* to COMPILE-TIME-EVAL.
  ;; 3/17/89 DNG - Avoid double-definition warning on a type-expander.
  ;;11/03/89 DNG - Added LAP-MODE and EVAL-FN as optional arguments.
  (DECLARE (SYMBOL TYPE))
  (UNLESS (ATOM FORM)
    ;; Start a new whack if FASD-TABLE is getting too big.
    (WHEN (AND (NOT QC-FILE-LOAD-FLAG)
	       FASD-STREAM
	       (>= (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD) )
      (FASD-END-WHACK) )
    ;; If supposed to fasdump as well as eval, do so first.
    (WHEN (EQ TYPE 'SPECIAL)
      (FUNCALL EVAL-FN FORM))

    ;; Check for duplicate definitions before the new definition is pushed on FILE-LOCAL-DECLARATIONS.
    (LET (FUNCTION-SPEC)
      (WHEN (AND (MEMBER (FIRST FORM) '(FDEFINE FSET SI:FSET) :TEST #'EQ)
		 (QUOTEP (SECOND FORM))
		 (file-local-def (SETQ FUNCTION-SPEC (second (second form))))
		 ;; The following check is needed for DEFTYPE, which does both a PUTDECL and DEFUN.
		 (NOT (AND (EQ (CAR-SAFE FUNCTION-SPEC) ':PROPERTY)
			   (EQ (THIRD FUNCTION-SPEC) 'SYS:TYPE-EXPANDER))))
	(WARN 'NOTICE-FDEFINE ':IMPLAUSIBLE "~S is defined twice in this file." FUNCTION-SPEC) ))

    ;; If supposed to evaluate at compile time, do so now.
    (WHEN (MEMBER TYPE '(SPECIAL DECLARE MACRO))
      (UNLESS (AND (EQ TYPE 'MACRO) QC-FILE-IN-CORE-FLAG)
	(COMPILE-TIME-EVAL FORM TYPE *LOCAL-ENVIRONMENT*)
	(WHEN (AND (EQ (FIRST FORM) 'IN-PACKAGE)
		   (EQ TYPE 'SPECIAL))
	  ;; make sure the dumper and loader are using the same default package
	  (SETQ FASD-PACKAGE *PACKAGE*))))
    ;; Finally, compile the form.
    (UNLESS (MEMBER TYPE '(SPECIAL DECLARE))
      (COMPILE-TOP-LEVEL-FORM FORM LAP-MODE EVAL-FN))))

 
(DEFUN compiler:COMPILE-DRIVER (OFORM PROCESS-FN OVERRIDE-FN &OPTIONAL COMPILE-TIME-TOO (TOP-LEVEL-P T))
  ;;  8/01/84 DNG - updated from MIT patches 98.40 and 98.57.
  ;; 12/26/84 DNG - Save value of DEFCONSTANT in FILE-CONSTANTS-LIST.
  ;;  1/18/85 DNG - Use COMPILE-PROCLAIM.
  ;;  2/20/85 DNG - Evaluate saved value of DEFCONSTANT.
  ;; 10/23/85 DNG - Fix handling of top-level COMPILER-LET so that the bindings
  ;;		    are implicitely special.  [SPR 837]
  ;;  1/16/86 DNG - Give warning on obsolete DEFUN syntax.
  ;;  1/27/86 DNG - Do style checking on random top-level forms.
  ;;  3/03/86 DNG - Fix so that an IMPORT within an EVAL-WHEN is fasdumped
  ;;		before being evaluated [SPR 1204]; bind *EVALHOOK* to
  ;;		#'EVAL-FOR-TARGET around macro expansion to use target definitions.
  ;;  3/18/86 DNG - Call CHECK-USED-BEFORE-DEFINED for DEFF-MACRO.
  ;;  5/19/86 DNG - Add special handling for EXPORT, IMPORT, etc. in cold-load.
  ;;  6/24/86 DNG - Fix to recognize PATCH-SOURCE-FILE in COMPILER package instead of COMPILER2.
  ;;  7/25/86 DNG -
  ;;  7/30/86 DNG - Evaluate COMPILATION-DEFINE at both compile and load time; always
  ;;		try to evaluate the value of a DEFCONSTANT at compile time.
  ;;  8/07/86 DNG - Major changes to minimize differences between top-level forms and functions.
  ;;  8/15/86 DNG - Don't optimize when an override function is given [ie, eval buffer].
  ;;  9/26/86 DNG - Added call to OBJECT-OPERATION-WITH-WARNINGS .
  ;; 11/21/86 DNG - Don't establish warnings context for a DEFPROP.
  ;;  2/11/87 DNG - Fix to not error on name starting with #\D but less that 3 characters.
  ;; 10/31/89 DNG - Change binding of MACRO-CONS-AREA so that 
  ;;		QCOMPILE-TEMPORARY-AREA will be used in Compile Buffer.  This is to 
  ;;		enable PRE-OPTIMIZE to distinguish macro expansions from source code for 
  ;;		issuing style warnings.
  ;; 11/03/89 DNG - ANSI conformance warning for PROCLAIM.
  ;; 11/06/89 DNG - Don't use the generic function name from a CLOS DEFMETHOD 
  ;;		form as the warnings object name.  Add binding of SOURCE-FORM.
  "Compile or evaluate a top-level form from a file or buffer."
  (WHEN (AND COMPILER-WARNINGS-CONTEXT
	     (NULL SI:OBJECT-WARNINGS-OBJECT-NAME)
	     (CONSP OFORM)
	     (SYMBOLP (FIRST OFORM))
	     (CADR-SAFE OFORM)
	     (SYMBOLP (SECOND OFORM))
	     (LET ((NAME (SYMBOL-NAME (FIRST OFORM))))
	       (AND (>= (LENGTH NAME) 3)
		    (CHAR= (CHAR NAME 0) #\D)
		    (CHAR= (CHAR NAME 1) #\E)
		    (CHAR= (CHAR NAME 2) #\F)))
	     (NOT (EQ (FIRST OFORM) 'DEFPROP))
	     (NOT (EQ (FIRST OFORM) 'CLOS:DEFMETHOD)))
    ;; A definition form that ZMACS knows how to find, so use it as a reference point
    ;; for reporting any errors within it.
    (RETURN-FROM COMPILE-DRIVER
      (OBJECT-OPERATION-WITH-WARNINGS ((SECOND OFORM))
	(COMPILE-DRIVER OFORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P))))
  (LET ((FORM OFORM))
    (WHEN (AND OVERRIDE-FN
	       (FUNCALL OVERRIDE-FN FORM))
      (RETURN-FROM COMPILE-DRIVER NIL))
    (LET ((MACRO-CONS-AREA (IF (AND QCOMPILE-TEMPORARY-AREA
				    (NOT (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA)))
			       QCOMPILE-TEMPORARY-AREA
			     DEFAULT-CONS-AREA))
	  (P1VALUE 'TOP-LEVEL-FORM))
      (SETQ FORM (PRE-OPTIMIZE FORM T OVERRIDE-FN))) ; check style, expand macros, and optimize
    (WHEN (AND OVERRIDE-FN
	       (NOT (EQ FORM OFORM))
	       (FUNCALL OVERRIDE-FN FORM))
      (RETURN-FROM COMPILE-DRIVER NIL))

    (IF (ATOM FORM)
	(FUNCALL PROCESS-FN FORM 'RANDOM)
      ;; If this was a top-level macro, supply a good guess
      ;; for the function-parent for any DEFUNs inside the expansion.
      (LET ((LOCAL-DECLARATIONS LOCAL-DECLARATIONS)
	    (FN (FIRST FORM)))
       (LET-IF (AND CHECK-CONFORMANCE TOP-LEVEL-P (NULL SOURCE-FORM)) ((SOURCE-FORM OFORM))
	(COND ((AND (NEQ FORM OFORM) (SYMBOLP (CADR OFORM)))
	       (PUSH `(FUNCTION-PARENT ,(CADR OFORM) ,(CAR OFORM))
		     LOCAL-DECLARATIONS)) )
	(COND ((EQ FN 'EVAL-WHEN)
	       (LET ((TIMES (SECOND FORM)))
		 (UNLESS (AND (LISTP TIMES)
			      (LOOP FOR TIME IN TIMES
				    ALWAYS (MEMBER TIME '(GLOBAL:EVAL LOAD COMPILE CLI:EVAL
								      #+compiler:debug Lisp:compile)
						   :TEST #'EQ)))
		   (WARN 'EVAL-WHEN ':IMPOSSIBLE "~S invalid EVAL-WHEN times;
must be a list of EVAL, LOAD, and/or COMPILE."
			 TIMES))
		 (LET* ((COMPILE (OR (MEMBER 'COMPILE TIMES :TEST #'EQ)
				     #+compiler:debug
				     (MEMBER 'Lisp:COMPILE TIMES :TEST #'EQ)))
			(LOAD (MEMBER 'LOAD TIMES :TEST #'EQ))
			(EVAL (OR (MEMBER 'GLOBAL:EVAL TIMES :TEST #'EQ) 
				  (MEMBER 'CLI:EVAL TIMES :TEST #'EQ)))
			(EVAL-NOW (AND (OR COMPILE (AND COMPILE-TIME-TOO EVAL)) T)))
		   (DOLIST (FORM1 (CDDR FORM))
		     (IF LOAD
			 (COMPILE-DRIVER FORM1 PROCESS-FN OVERRIDE-FN EVAL-NOW NIL)
		       (IF EVAL-NOW
			   (FUNCALL PROCESS-FN FORM1 'DECLARE)
			 (RETURN) ))))))
	      ((EQ FN 'WITH-SELF-ACCESSIBLE) ; Why is this here???
	       (MAPC #'(LAMBDA (FORM)
			 (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO NIL))
		     (CDDR FORM)))
	      ((EQ FN 'PROGN)
	       (MAPC #'(LAMBDA (FORM)
			 (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P))
		     (CDR FORM)))
	      ((AND (OR TOP-LEVEL-P COMPILE-TIME-TOO)
		    (MEMBER FN '(SPECIAL UNSPECIAL COMPILATION-DEFINE 
				 MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT
				 EXPORT UNEXPORT USE-PACKAGE UNUSE-PACKAGE IMPORT
				 REQUIRE)
			    :TEST #'EQ))
	       (COND ((AND SI:FILE-IN-COLD-LOAD
			   (MEMBER FN '(EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW
					USE-PACKAGE UNUSE-PACKAGE)
				   :TEST #'EQ)
			   (EQL (LENGTH FORM) 2))
		      ;; For cold-load files, these operations need an explicit package
		      ;; argument because we can't be sure what *PACKAGE* will be at the
		      ;; time the form is actually executed.
		      (SETQ FORM (LIST (FIRST FORM) (SECOND FORM) (PACKAGE-NAME *PACKAGE*))))
		     )
	       (FUNCALL PROCESS-FN FORM 'SPECIAL))
	      ((EQ FN 'DECLARE)
	       (COMPILE-DECLARE (CDR FORM) PROCESS-FN))
	      ((EQ FN 'PROCLAIM)
	       (WHEN (AND (EQ CHECK-CONFORMANCE ':ANSI)
			  TOP-LEVEL-P
			  (NEQ (FIRST OFORM) 'CL:DECLAIM))
		 (LET ((*PRINT-PRETTY* T))
		   (CONFORMANCE-WARNING "In ANSI CL, top level ~S won't be executed at compile time;
  either wrap an EVAL-WHEN around it or use ~S instead."
					FORM
					(IF (QUOTEP (SECOND FORM))
					    `(CL:DECLAIM ,(SECOND (SECOND FORM)))
					  'CL:DECLAIM))))
	       (COMPILE-PROCLAIM (CDR FORM) PROCESS-FN))
	      ((EQ FN 'COMMENT) NIL)
	      ((EQ FN 'COMPILER:PATCH-SOURCE-FILE)
	       (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL)
				  (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING ,(CADR FORM)))
			       PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P)
	       (MAPC #'(LAMBDA (FORM)
			 (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P))
		     (CDDR FORM))
	       (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL)
				  (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING NIL))
			       PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P))
	      ((EQ FN 'COMPILER-LET)
	       (*EVAL `(COMPILER-LET ,(CADR FORM)
			 (COMPILE-DRIVER '(PROGN . ,(CDDR FORM))
					 ',PROCESS-FN ',OVERRIDE-FN
					 ',COMPILE-TIME-TOO
					 ',TOP-LEVEL-P))))
	      (COMPILE-TIME-TOO		   ; EVAL-WHEN (COMPILE LOAD) 
	       (FUNCALL PROCESS-FN FORM 'MACRO))
	      (T			   ; EVAL-WHEN (LOAD)
	       (FUNCALL PROCESS-FN FORM 'RANDOM))
	      )))))
  NIL)

 
(DEFUN (:PROPERTY DEFF-MACRO compiler::STYLE-CHECKER) (FORM)
  ;; 11/01/89 DNG - Add call to CHECK-FORM-FOR-NON-STANDARD-FUNCTION.
  (WHEN (TOP-LEVEL-DUMMY-FUNCTION-P)
    (CHECK-USED-BEFORE-DEFINED (SECOND FORM) "macro"))
  (CHECK-FORM-FOR-NON-STANDARD-FUNCTION FORM))


))




#!C
; From file COMPILE.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; COMPILE.É#É"

(DEFUN compiler:QC-TRANSLATE-FUNCTION (FUNCTION-SPEC EXP QC-TF-PROCESSING-MODE QC-TF-OUTPUT-MODE
			      &OPTIONAL (NAME-FOR-FUNCTION FUNCTION-SPEC) PASS-1-ONLY)
  "Compile one function.  All styles of the compiler come through here.
QC-TF-PROCESSING-MODE should be MACRO-COMPILE or MICRO-COMPILE.
QC-TF-OUTPUT-MODE is used by LAP to determine where to put the compiled code.
 It is COMPILE-TO-CORE for making an actual FEF; QFASL, REL, or
 QFASL-NO-FDEFINE to simply dump a FEF without trying to define a function.
EXP is the lambda-expression.
NAME-FOR-FUNCTION is what the fef's name field should say;
 if omitted, FUNCTION-SPEC is used for that too.
In MACRO-COMPILE mode, the return value is the value of QLAPP for the first function."
  ;;  7/15/85 - Don't call PEEP when HOLDPROG is NIL.
  ;;  2/01/86 - Moved binding of some special variables from QCOMPILE0 to around its call.
  ;;  3/13/86 - Bind *BARF-DEFAULTS* to NIL.
  ;;  4/25/86 - Set *LAST-ADDRESS-READ* if not already set by COMPILE-STREAM.
  ;;  5/06/86 - Fix to allow EXP in DEBUG-INFO-AREA.
  ;;  5/24/86 DNG - Split out CHECK-FOR-UNUSED-VARIABLES as a separate function.
  ;;  5/28/86 DNG - Use a lexical closure instead of a dynamic closure for ERROR-MESSAGE-HOOK.
  ;;  6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.
  ;;  7/10/86 DNG - Revised to use COMPILAND structure instead of COMPILER-QUEUE-ENTRY.
  ;;  7/30/86 DNG - New argument PASS-1-ONLY.
  ;;  9/24/86 DNG - Modify "give up" handling to skip the rest of the queue.
  ;;  9/25/86 DNG - Removed the second call to OBJECT-OPERATION-WITH-WARNINGS because it was
  ;;		masking warnings recorded by the call in BREAKOFF.
  ;; 11/14/86 DNG - Watch out for write-protected area SOURCE-CODE-AREA.
  ;;  2/07/87 DNG - Use new function WRITE-PROTECTED-AREA-P .
  ;;  3/07/87 DNG - Clear QCMP-OUTPUT array to facilitate GC.
  ;;  7/22/87 DNG - Eliminate use of *LAST-ADDRESS-READ*.
  ;;  7/30/87 DNG - For in-memory compile, bind MACRO-CONS-AREA to QCOMPILE-TEMPORARY-AREA
  ;;		instead of BACKGROUND-CONS-AREA.
  ;;  7/26/88 JHO - Added   FILE-LOCAL-DECLARATIONS-DEF-ALIST to LET
  ;;  8/16/88 clm - Use only FILE-LOCAL-DECLARATIONS-DEF-ALIST to keep track of DEFinitions
  ;;                (no longer keep same info in FILE-LOCAL-DECLARATIONS).
  ;; 10/25/88 DNG - Remove binding of *LOCAL-ENVIRONMENT*.
  ;;  3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore.
  ;;  4/06/89 DNG - Add binding of *LOCAL-ENVIRONMENT*.
  ;;  4/26/89 DNG - Add binding of *LOOP-VAR-BIT*.
  ;; 11/03/89 DNG - Add CHECK-ONLY mode.
  (OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)
    (LET* ((DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)
	   (ERROR-MESSAGE-HOOK
	     ;; Note: this function cannot reference special variables because
	     ;; it will be executed by the error handler in a different stack group.
	     ;; Construct a lexical closure over the function name.
	     (AND NAME-FOR-FUNCTION
		  #'(LAMBDA ()
		      (FORMAT T "Error occurred while compiling ~S"
			      NAME-FOR-FUNCTION))))
	   COMPILER-QUEUE
	   (WARN-CATCHER NIL)
	   (COMPILING-COMMON-LISP (COMMON-LISP-ON-P))
	   (VAL NIL)
	   (THIS-FUNCTION-BARF-SPECIAL-LIST NIL)
	   (GIVE-UP-NAME NAME-FOR-FUNCTION)
	   ( *BARF-DEFAULTS* NIL ))
      (IF (ARRAYP EXP)
	  (SETQ COMPILER-QUEUE (CONS EXP NIL))
	(PROGN
	  (SETQ COMPILER-QUEUE
		(CONS (MAKE-COMPILAND 
			:FUNCTION-SPEC FUNCTION-SPEC
			:FUNCTION-NAME NAME-FOR-FUNCTION
			:DEFINITION    EXP
			:DECLARATIONS  LOCAL-DECLARATIONS)
		      NIL))
	  ))
      (LOOP ; for each FEF to be generated
	(WHEN (NULL COMPILER-QUEUE) (RETURN))
	(LET* ((CURRENT (FIRST COMPILER-QUEUE))
	       (*CURRENT-COMPILAND* CURRENT)
	       (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE CURRENT))
	       )
	  (SETQ NAME-FOR-FUNCTION (COMPILAND-FUNCTION-NAME CURRENT))
	  (UNLESS (EQ (CAR-SAFE NAME-FOR-FUNCTION) ':INTERNAL)
	    (SETQ GIVE-UP-NAME NAME-FOR-FUNCTION))
	  (progn ;OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)
	    (MULTIPLE-VALUE-BIND ( NIL ERROR-CAUGHT )
	      (CATCH-ERROR-RESTART (ERROR "Give up on compiling ~S" GIVE-UP-NAME)
		;;
		;;		Pass 1
		;;
		(WHEN (OR (COMPILAND-EXP2 CURRENT) ; pass 1 already done
			  (LET (( VARS NIL )
				( VAR-BIT (ASH (MAX SPECIAL-VAR-BIT DATA-ALTERATION-BIT) 1) )
				( *LOOP-VAR-BIT* 0 )
				( ALTERED-VAR-SET 0 )
				( USED-VAR-SET 0 )
				( PROPAGATE-VAR-SET 0 )
				( SUBST-VAR-SET 0 )
				( LOCAL-FUNCTIONS NIL )
				( PROGDESCS NIL )
				( RETPROGDESC NIL )
				( GOTAGS NIL )
				( 1-IF-LIVE-CODE 1 )
				( FILE-LOCAL-DECLARATIONS FILE-LOCAL-DECLARATIONS )
				( MACRO-CONS-AREA (IF (AND (EQ QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE)
							   (SI:AREA-TEMPORARY-P DEFAULT-CONS-AREA))
						      BACKGROUND-CONS-AREA
						    DEFAULT-CONS-AREA) ) ; for PRE-OPTIMIZE
				( *LOCAL-ENVIRONMENT*
				 ;; Bind this so that the SETF of FILE-LOCAL-DEF below will be temporary.
				 (LIST* (ENV-VARS *LOCAL-ENVIRONMENT*)
					(CONS NIL (ENV-FUNCTIONS *LOCAL-ENVIRONMENT*))
					(CDDR *LOCAL-ENVIRONMENT*)))
				)

			    (UNLESS (LISTP (COMPILAND-FUNCTION-SPEC CURRENT)) ; non-NIL symbol
			      (LET ((*COMPILE-FILE-ENVIRONMENT* *LOCAL-ENVIRONMENT*))
				(setf (file-local-def (COMPILAND-FUNCTION-SPEC CURRENT))
				      (COMPILAND-DEFINITION CURRENT))) )

			    (LET ((RESULT (QCOMPILE1 CURRENT)))  ; do pass 1 on top-level function
			      (SETF (COMPILAND-USED-VAR-SET CURRENT) USED-VAR-SET)
			      (SETF (COMPILAND-ALTERED-VAR-SET CURRENT) ALTERED-VAR-SET)
			      (COND ((EQ QC-TF-OUTPUT-MODE 'CHECK-ONLY)
				     ;; just want warnings, no object code, so pass 1 is all that is needed.
				     (BUILD-DEBUG-INFO CURRENT) ; to update compile-time environment
				     NIL) 
				    (PASS-1-ONLY	; return partially compiled result
				     (SETQ VAL CURRENT)
				     (SETQ PASS-1-ONLY NIL)	; only applies to first queue entry
				     NIL)	; don't do pass 2 yet
				    (T RESULT) ))))
		  ;; pass 1 succeded; continue.
		  ;;
		  ;;		Pass 2
		  ;;
		  (QCOMPILE2 CURRENT)	   ; pass 2 on sub-function
		  (WHEN HOLDPROG
		    ;;
		    ;;		Peephole optimizer
		    ;;
		    (WHEN (AND PEEP-ENABLE
			       (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)
				   (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))
			       (NEQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE))
		      (record-individual-time 'peep
			(PEEP QCMP-OUTPUT (COMPILAND-FUNCTION-SPEC CURRENT))))
		    ;;
		    ;;		QLAPP
		    ;;
		    (COND ((EQ QC-TF-PROCESSING-MODE 'MACRO-COMPILE)
			   (LET* ((LAP-CODE (G-L-P QCMP-OUTPUT))
				  (LAP-RESULT
				    (record-individual-time 'qlapp
				      (IF (EQ QC-TF-OUTPUT-MODE 'BOTH)
					  (PROGN
					    (QLAPP LAP-CODE 'QFASL)
					    (QLAPP LAP-CODE 'COMPILE-TO-CORE))
					(QLAPP LAP-CODE QC-TF-OUTPUT-MODE)))))
			     (UNLESS VAL (SETQ VAL LAP-RESULT))))
			  ((EQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE)
			   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
			     (MICRO-COMPILE (G-L-P QCMP-OUTPUT) QC-TF-OUTPUT-MODE)))
			  #+compiler:debug
			  (T (BARF QC-TF-PROCESSING-MODE "invalid compile mode" 'BARF))
			  )
		    ) ; end HOLDPROG
		  (UNLESS (SI:AREA-TEMPORARY-P DEFAULT-CONS-AREA)
		    ;; When TGC is in use, clear out the active portion of this
		    ;; array as soon as we are finished with it so that the
		    ;; contents can be garbage-collected.
		    (ARRAY-INITIALIZE QCMP-OUTPUT NIL)
		    (SETF (FILL-POINTER QCMP-OUTPUT) 0))
		  NIL))
	      (WHEN ERROR-CAUGHT
		(WHEN (< *RETURN-STATUS* FATAL)
		  (SETQ *RETURN-STATUS* FATAL))
		;; If compilation of a function is aborted, then can't meaningfully
		;; continue compiling its children, so return out of the loop.
		(RETURN) )
	    )))
	(POP COMPILER-QUEUE)) ; end of LOOP
      VAL)))

(DEFUN compiler:ASSIGN-LAP-ADDRESSES (COMPILAND)
  ;;  7/11/85 - Don't share slots used in lexical closures.
  ;;  9/25/85 - Make ARG-MAP and LOCAL-MAP entries be a symbol instead of a list.
  ;; 12/07/85 - Delete use of CLOBBER-NONSPECIAL-VARS-LISTS since it was always NIL.
  ;; 12/16/85 - Fix to not share storage with a deleted variable; remove FEF-REMOTE.
  ;;  1/10/86 - Reserve local slots for VM2 lexical closure implementation.
  ;;  7/08/86 - Revised to use COMPILAND structure.
  ;; 10/18/86 - Call EXTEND-LOCAL-VARIABLES if more than 64 local slots are needed.
  ;;  5/04/88 DNG - Remove ARG-MAP, which is not used anymore.  Add support 
  ;;		for CLOS mapping tables and improve reservation for lexical closures.
  ;;  5/12/88 DNG - Fix to reserve LEX-ALL-VECTORS-REG.
  ;; 11/08/88 DNG - Omit the local map if none of the local slots are 
  ;;		referenced.  (Saves space for trivial methods.)
  ;; 12/22/88 DNG - Fix error reporting for too many &KEY args.
  (DECLARE (special  SYS:LOCAL-FOR-FIRST-MAPPING-TABLE)
	   (VALUES LVCNT)) ;Count rest arg, auxes, and internal-auxes if they are not special.
  (LET* ((ARGN 0) ;Next arg number to allocate.
	 (FIRST-UNUSED-LOCAL 0) ; the lowest number local slot not yet allocated.
	 (LOCALS-END 0) ; slot number after the last one used.
	 (EMPTY 0) ; unallocated slot marker
	 (LOCAL-SLOTS (MAKE-ARRAY MAX-LOCAL-SLOTS :INITIAL-ELEMENT EMPTY))
	 (LOCALS-USED NIL)
	 )
    (DECLARE (FIXNUM ARGN FIRST-UNUSED-LOCAL LOCALS-END))
    (FLET ((ALLOCATE-LOCAL (NUMBER NAME)
			   (debug-assert (let ((old (aref local-slots number)))
					   (or (eq old empty) (eq old name))))
			   (SETF (AREF LOCAL-SLOTS NUMBER) NAME)
			   (WHEN (>= NUMBER LOCALS-END)
			     (SETQ LOCALS-END (1+ NUMBER)))
			   NUMBER) )
      (FLET ((DEDICATE-LOCAL (NAME)
			     (ALLOCATE-LOCAL (SYMBOL-VALUE NAME) NAME) ))
	;; Reserve registers needed by microcode when dealing with lexical closures.
	(WHEN (> (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) 0)
	  ;; current function makes lexical closures
	  (DEDICATE-LOCAL 'LEX-PARENT-ENV-REG)
	  (DEDICATE-LOCAL 'LEX-CURRENT-VECTOR-REG)
	  (WHEN (OR T ; Temporarily need to always reserve this slot until			<====<<<  ???
		    ;; (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) is updated to not issue 
		    ;; UNSHARE instructions when all closures are ephemeral. -- DNG 5/12/88
		    (DOLIST (CHILD (COMPILAND-CHILDREN COMPILAND) NIL)
		      (LET ((X (COMPILAND-LEXICAL-CLOSURE-FLAG CHILD)))
			(WHEN (AND (CONSP X) (NOT (THIRD X)))
			  ;; makes a non-ephemeral lexical closure
			  (RETURN T)))))
	    (DEDICATE-LOCAL 'LEX-ALL-VECTORS-REG)) )
	(WHEN (NOT (NULL *LEXICAL-REGISTER-LEVELS*))
	  ;; current function is a lexical closure.
	  (DEDICATE-LOCAL 'LEX-PARENT-ENV-REG)
	  (WHEN (SECOND *LEXICAL-REGISTER-LEVELS*)
	    ;; current function is a lexical closure referencing more than one level.
	    (DEDICATE-LOCAL 'LEX-ENV-B-REG)))
	)
      (DOLIST (V (REVERSE (COMPILAND-ALLVARS COMPILAND)))
	;; Cons up the expression for Lap to use to refer to this variable.
	(LET* ((TYPE (VAR-TYPE V))
	       (KIND (VAR-KIND V))
	       (NAME (VAR-NAME V))
	       (OVERLAPS NIL)
	       ;; If the name is in the temporary area or is uninterned, don't put it in the
	       ;; arg/local map.  This is partly to avoid putting all these stupid gensyms
	       ;; into the object file, but the real reason is to avoid the dreaded scourge
	       ;; of temporary area lossage in the error handler.
	       (PERMANENT-NAME (UNLESS (= (%AREA-NUMBER NAME) QCOMPILE-TEMPORARY-AREA)
				 (WHEN (SYMBOL-PACKAGE NAME)
				   NAME))) )
	  (SETF (VAR-LAP-ADDRESS V)
		(COND ((EQ KIND 'FEF-ARG-DELETED)
		       `(FEF-ARG-DELETED ,NAME)) ; dummy entry, shouldn't be referenced
		      ((EQ TYPE 'FEF-SPECIAL)
		       `(SPECIAL ,NAME))
		      ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ)
		       (PROG1 `(ARG ,ARGN)
			      (WHEN (= ARGN MAX-LOCAL-SLOTS)
				(WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT
				      "More than ~D arguments accepted by one function."
				      MAX-LOCAL-SLOTS))
			      (INCF ARGN)))
		      ((PROGN (UNLESS (MEMBER (VAR-USE-COUNT V) '(0 NIL))
				(SETQ LOCALS-USED T))
			      NIL))
		      ((EQ KIND 'FEF-ARG-REST)
		       (ALLOCATE-LOCAL 0 PERMANENT-NAME)
		       `(LOCBLOCK 0) )
		      (T (SETQ OVERLAPS (VAR-OVERLAP-VAR V))
			 (WHEN (AND OVERLAPS
				    (OR (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES
						(VAR-MISC V))
					(NEQ KIND (VAR-KIND OVERLAPS))	; make sure it wasn't deleted
					))
			   ;; can't really share storage after all.
			   (SETF (VAR-OVERLAP-VAR V) NIL)
			   (SETF OVERLAPS NIL) )
			 (COND (OVERLAPS
				(UNLESS (NULL PERMANENT-NAME)
				  (LET* ((NUMBER (SECOND (VAR-LAP-ADDRESS OVERLAPS)))
					 (OLD (AREF LOCAL-SLOTS NUMBER)))
				    (IF (LISTP OLD)
					(UNLESS (MEMBER PERMANENT-NAME OLD :TEST #'EQ)
					  (SETF (AREF LOCAL-SLOTS NUMBER)
						(CONS PERMANENT-NAME OLD)))
				      (UNLESS (EQ PERMANENT-NAME OLD)
					(SETF (AREF LOCAL-SLOTS NUMBER)
					      (LIST PERMANENT-NAME OLD)) ))))
				(VAR-LAP-ADDRESS OVERLAPS))
			       ((EQ NAME 'SI:.DAEMON-MAPPING-TABLE.)
				;; This magic variable used in combined flavor methods must
				;;  always be LOCAL|1 because the microcode expects to
				;;  find it there when doing a %SET-SELF-MAPPING-TABLE .
				`(LOCBLOCK ,(ALLOCATE-LOCAL SYS:LOCAL-FOR-FIRST-MAPPING-TABLE
							    PERMANENT-NAME)))
			       ((AND (EQ KIND 'FEF-ARG-KEY)
				     (EQ (VAR-INIT-KIND V) 'FEF-INI-MAP))
				;; A CLOS mapping table or continuation that must go in a particular slot.
				`(LOCBLOCK ,(ALLOCATE-LOCAL (VAR-INIT-FORM V) PERMANENT-NAME)))
			       (T (LOOP UNTIL (OR (= FIRST-UNUSED-LOCAL LOCALS-END)
						  (EQ (AREF LOCAL-SLOTS FIRST-UNUSED-LOCAL) EMPTY))
					DO (INCF FIRST-UNUSED-LOCAL))
				  (WHEN (>= FIRST-UNUSED-LOCAL MAX-LOCAL-SLOTS)
				    (IF (EXTEND-LOCAL-VARIABLES COMPILAND)
					(RETURN-FROM ASSIGN-LAP-ADDRESSES
					  (ASSIGN-LAP-ADDRESSES COMPILAND))
				      (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT
					    (IF (EQ KIND 'FEF-ARG-KEY)
						"More than ~D keyword arguments used."
					      "More than ~D local variable slots required by one function.")
					    MAX-LOCAL-SLOTS)))
				  `(LOCBLOCK ,(ALLOCATE-LOCAL
						(IF (AND (EQ KIND 'FEF-ARG-KEY)
							 (< FIRST-UNUSED-LOCAL LOCALS-END))
						    ;; &key args must be contiguous
						    (IF (< LOCALS-END MAX-LOCAL-SLOTS)
							LOCALS-END
						      (PROGN
						        (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT
							      "More than ~D keyword arguments used."
							      #.(- MAX-LOCAL-SLOTS
								   SYS:LOCALS-FOR-MAPPING-TABLE-BASE))
							FIRST-UNUSED-LOCAL))
						  (PROG1 FIRST-UNUSED-LOCAL
							 (INCF FIRST-UNUSED-LOCAL)))
						PERMANENT-NAME)))))))
	  ))
      (LET ((LOCAL-MAP '()))
	(DECLARE (UNSPECIAL LOCAL-MAP) (LIST LOCAL-MAP))
	(WHEN LOCALS-USED
	  (DO ((I (- LOCALS-END 1) (- I 1)))
	      ((< I 0))
	    (LET ((NAME (AREF LOCAL-SLOTS I)))
	      (WHEN (EQ NAME EMPTY) (SETQ NAME NIL))
	      (UNLESS (AND (NULL NAME) (NULL LOCAL-MAP))
		(PUSH NAME LOCAL-MAP)))))
	(SETF (COMPILAND-LOCAL-MAP COMPILAND) (COPY-LIST LOCAL-MAP)))
      LOCALS-END))) 

(DEFUN COMPILER:BUILD-DEBUG-INFO (COMPILAND)
  ;; Set up the debug info from the local declarations and other things.
  ;; Note that the most frequently used information should be pushed last
  ;; so it will be at the front of the list.
  ;;
  ;; 12/27/84 DNG - Save DEFUN-METHOD definitions on FILE-LOCAL-DECLARATIONS.
  ;;  2/15/85 DNG - Remember function which redefines a macro or subst.
  ;;  3/07/85 DNG - Don't push COMPILER-ARGLIST when redundant.
  ;;  3/29/85 DNG - Fix to not mark all DEFSUBSTs with '(:NO-SIMPLE-SUBSTITUTION T).
  ;;  4/09/85 DNG - Fix for EXPANSION which is an atom.
  ;;  4/23/85 DNG - Save interpreted definition of small functions in the
  ;;		    GLOBAL package to allow later inline expansion.
  ;;  7/12/85 DNG - Include LOCAL-FUNCTION-MAP in the debug info.
  ;; 10/03/85 DNG - Fix to remember method definitions in COMPILE-FILE for
  ;;		    integration later in the file.
  ;; 10/21/85 DNG - Don't record debug info when *SUPPRESS-DEBUG-INFO* is true.
  ;; 11/16/85 DNG - Generate new debug-info structure for release 3.
  ;;  1/09/86 DNG - New field :VARIABLES-USED-IN-LEXICAL-CLOSURES.
  ;;  2/01/86 DNG - Record debug info lexical parent function;
  ;;		    don't suppress documentation of external functions.
  ;;  3/18/86 DNG - Use new function CHECK-USED-BEFORE-DEFINED to warn about
  ;;		macros etc. used before defined.
  ;;  3/21/86 DNG - Always use new debug info structure when compiling for VM2.
  ;;  4/24/86 DNG - On VM2, use ARGS-DESC instead of ARGS-INFO.
  ;;  5/08/86 DNG - Use new function COPY-TO-PROPER-AREA on debug info lists;
  ;;		bind FUNCTION-PROPERTY-AREA around call to MAKE-DEBUG-INFO-STRUCT.
  ;;  5/22/86 DNG - Don't save interpreted defn. for symbols with QLVAL property.
  ;;  6/09/86 DNG - Make sure the function name is in the proper area; remove
  ;;		binding of FUNCTION-PROPERTY-AREA which is no longer needed.
  ;;  6/16/86 DNG - Temporary special handling of COMBINED-METHOD-DERIVATION and
  ;;		WRAPPER-SXHASHES debug info when cross-compiling.
  ;;  6/18/86 DNG - Modify handling of EXPR-DEBUG-INFO.
  ;;  7/08/86 DNG - New function BUILD-DEBUG-INFO replaces SET-UP-DEBUG-INFO.
  ;;  7/22/86 DNG - Don't suppress :ARGLIST when it contains &QUOTE.
  ;;  7/31/86 DNG - Macro definitions are now saved on FILE-LOCAL-DECLARATIONS
  ;;		here instead of in the special forms DEFMACRO and DEFSUBST.
  ;;  8/04/86 DNG - Avoid using QC-TF-OUTPUT-MODE here.
  ;;  8/12/86 DNG - Don't push macro definition on FILE-LOCAL-DECLATIONS when already done.
  ;; 10/08/86 DNG - Don't save interpreted definition of fasload-combined methods.
  ;; 10/11/86 DNG - Record hash code for DEFSUBSTs and inline functions as well as macros.
  ;; 10/17/86 DNG - Use new function EQUIVALENT-FORMS-P .
  ;; 10/19/86 DNG - Add support for phantom variables.
  ;; 11/15/86 DNG - Fix reference to EXPRESSION-SIZE.
  ;; 11/21/86 DNG - Test OPCODE property instead of QLVAL or TWO-ARGUMENT-FUNCTION.
  ;;  1/06/87 DNG - Fix to not put temporary area gensyms in the :VARIABLES-USED-IN-LEXICAL-CLOSURES list.
  ;;  2/18/87 DNG - Fix several problems with the *SUPPRESS-DEBUG-INFO* option.
  ;;  6/17/87 DNG - Fix to not save the interpreted definition for possible inline
  ;;		expansion in any of the following cases:
  ;;		  * The name is NIL [SPR 5237] or an uninterned symbol.
  ;;		  * The name is an :INTERNAL or :LOCATIVE function spec.
  ;;		  * The function is a lexical closure.
  ;;		Also make *SUPPRESS-DEBUG-INFO* prevent saving the interpreted definition
  ;;		just because the compilation is done in memory
  ;;  5/23/88 CLM - New field :CONTINUATION-SLOT for CLOS, store the local offset of the
  ;;                continuation if there is one.
  ;;  7/26/88 JHO - Added update of FILE-LOCAL-DECLARATIONS-DEF-ALIST.
  ;;  8/16/88 clm - Use only FILE-LOCAL-DECLARATIONS-DEF-ALIST to keep track of DEFinitions
  ;;                (no longer keep same info in FILE-LOCAL-DECLARATIONS).
  ;; 10/20/88 DNG - Omit declared ARGLIST that is same as real arglist.
  ;; 11/15/88 DNG - Don't save interpreted definition of generic functions or 
  ;;		methods.  Strip trailing nulls from the :INTERNAL-FEF-NAMES list.
  ;; 11/17/88 DNG - Don't keep NOTINLINE information from PROCEDURE-INTEGRATION.
  ;; 12/29/88 DNG - Do save interpreted definition for encapsulations.
  ;;  2/10/89 DNG - Record specializer names in debug info if not included in the name.
  ;;  4/07/89 DNG - Add use of FUNCTION-FOR-TARGET.
  ;;  4/25/89 DNG - Add use of COMPILAND-CONSTANTS-EXPANDED for SPR 6501.
  ;;  8/22/89 DNG - For CLOS methods, don't record :FUNCTION-PARENT of the 
  ;;		generic function name.  Besides being unnecessary, this was confusing 
  ;;		Zmacs.  [SPR 10460]
  (LET* (( SUPPRESS-DEBUG	*SUPPRESS-DEBUG-INFO* )
	 ( SUPPRESS-ARGS	SUPPRESS-DEBUG )
	 ( FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC COMPILAND))
	 ( EXPR-DEBUG-INFO	(COMPILAND-DEBUG-INFO	COMPILAND) )
	 ( TRE-ARGS		(COMPILAND-ARGLIST	COMPILAND) )
	 ( MACROFLAG		(COMPILAND-MACRO-FLAG	COMPILAND) )
	 ( EXP			(COMPILAND-DEFINITION	COMPILAND) )
	 ( SUBST-FLAG		(COMPILAND-SUBST-FLAG	COMPILAND) )
	 ( DOCUMENTATION	(COMPILAND-DOCUMENTATION COMPILAND) )
	 ( MACROS-EXPANDED	(COMPILAND-MACROS-EXPANDED COMPILAND) )
	 ( CONSTANTS-EXPANDED	(COMPILAND-CONSTANTS-EXPANDED COMPILAND) )
	 ( QUOTED-ARG  (MEMBER '&QUOTE TRE-ARGS :TEST #'EQ)  ))
    (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED MACROS-EXPANDED))
    (WHEN SUPPRESS-ARGS
      (IF (AND FUNCTION-TO-BE-DEFINED (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED))
	  ;; always provide arglist and doc string for externally defined functions
	  (SETQ SUPPRESS-ARGS NIL)
	(SETQ DOCUMENTATION NIL))
      (IF (MEMBER SUPPRESS-DEBUG '( :DOCUMENTATION DOCUMENTATION ))
	  ;; suppress doc string only
	  (SETQ SUPPRESS-ARGS NIL  SUPPRESS-DEBUG NIL)
	(WHEN (AND SUPPRESS-ARGS
		   (NOT (COMPILING-FOR-V2)) ; temporary until the implications can be considered
		   (NOT SUBST-FLAG) (NOT MACROFLAG)
		   (NOT (AND QUOTED-ARG (COMPILING-FOR-V2)))
		   (NULL (COMPILAND-CHILDREN COMPILAND))
		   (NOT (EQ (CAR-SAFE FUNCTION-TO-BE-DEFINED) :METHOD))
		   (NULL (INLINE-DECL FUNCTION-TO-BE-DEFINED)))
	  (RETURN-FROM BUILD-DEBUG-INFO
	    (SETF (COMPILAND-DEBUG-INFO COMPILAND) '#,(SI:MAKE-DEBUG-INFO-STRUCT :NAME NIL))))))
    (WHEN (AND (NULL FUNCTION-TO-BE-DEFINED)
	       (NULL (ASSOC 'SYS:FUNCTION-PARENT EXPR-DEBUG-INFO)))
      (LET ((PARENT (COMPILAND-PARENT COMPILAND)))
	(UNLESS (NULL PARENT)
	  (LET ((DCL (ASSOC 'SYS:FUNCTION-PARENT (COMPILAND-DEBUG-INFO PARENT))))
	    (UNLESS (NULL DCL)
	      (PUSH DCL EXPR-DEBUG-INFO))))))
      ;;
      ;;	   --  Debug info structure for release 3  --
      ;;
    (LET ( DBI ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS
					    (NOT QC-FILE-LOAD-FLAG))
				       DEFAULT-CONS-AREA
				     BACKGROUND-CONS-AREA) ))
	  (IF (LISTP EXPR-DEBUG-INFO)
	      (PROGN
		(SETQ DBI (SI:MAKE-DEBUG-INFO-STRUCT
			    :NAME (COPY-TO-PROPER-AREA
				    (COMPILAND-FUNCTION-NAME COMPILAND))))
		(DOLIST (DCL EXPR-DEBUG-INFO)
		  (LET (( DT (OR (CDR (ASSOC (CAR DCL)
					     SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*
					     :TEST #'EQ))
				 (CAR DCL)) ))
		    (UNLESS (OR (SI:GET-DEBUG-INFO-FIELD DBI DT)
				;; Suppress redundant FUNCTION-PARENT declaration.
				(AND (EQ DT ':FUNCTION-PARENT)
				     (OR (EQUAL (SECOND DCL) (COMPILAND-FUNCTION-NAME COMPILAND))
					 (AND (EQ (THIRD DCL) 'DEFMETHOD)
					      (CONSP FUNCTION-TO-BE-DEFINED)
					      (EQUAL (SECOND DCL) (SECOND FUNCTION-TO-BE-DEFINED)))
					 ))
				;; Suppress declared ARGLIST that is same as real arglist.
				(AND (EQ DT ':DESCRIPTIVE-ARGLIST)
				     (EQUAL (CDR DCL) TRE-ARGS))
				(EQ DT 'NOTINLINE) ; used internally by PROCEDURE-INTEGRATION
				)
		      (SI:PUT-DEBUG-INFO-FIELD
			DBI
			DT
			(COPY-TO-PROPER-AREA (CDR DCL)) )))))
	    (SETQ DBI EXPR-DEBUG-INFO) )
	  (UNLESS (NULL DOCUMENTATION)
	    (SI:PUT-DEBUG-INFO-FIELD DBI :DOCUMENTATION (COPY-TO-PROPER-AREA DOCUMENTATION)) )
	  (UNLESS SUPPRESS-DEBUG
	    ;; If we aren't going to mark this function as requiring a mapping
	    ;; table, provide anyway some info that the user declared it wanted one.
	    (WHEN (AND (COMPILAND-FLAVOR COMPILAND) (NOT (COMPILAND-SELF-MAP-NEEDED COMPILAND)))
	      (SI:PUT-DEBUG-INFO-FIELD DBI :SELF-FLAVOR (CAR (COMPILAND-FLAVOR COMPILAND))) )
	    (WHEN (AND (COMPILAND-PARENT COMPILAND)
		       (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND))
	      (SI:PUT-DEBUG-INFO-FIELD DBI
				       :LEXICAL-PARENT-DEBUG-INFO
				       (COMPILAND-DEBUG-INFO
					 (COMPILAND-PARENT COMPILAND))))
	    (LET ((LEXVARS (GETF (COMPILAND-PLIST COMPILAND) 'PHANTOM-VARS)))
	      ;; phantom variables are created by EXTEND-LOCAL-VARIABLES 
	      (IF (NULL LEXVARS)
		  (SETQ LEXVARS (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND))
		(SETQ LEXVARS (APPEND (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)
				      LEXVARS)))
	      (UNLESS (NULL LEXVARS)
		(SI:PUT-DEBUG-INFO-FIELD
		  DBI
		  :VARIABLES-USED-IN-LEXICAL-CLOSURES
		  (LOOP FOR HOME IN LEXVARS COLLECT
			(LET ((NAME (VAR-NAME HOME)))
			  (IF (AND (SYMBOLP NAME) (NULL (SYMBOL-PACKAGE NAME)))
			      ;; Intern gensyms so the symbol won't be in the temporary area.
			      ;; Needed for the variables created by P1BLOCK to hold the BLOCK exit throw tag.
			      (INTERN (SYMBOL-NAME NAME))
			    NAME))
			) ))) )
	  (WHEN (COMPILAND-CHILDREN COMPILAND)
	    ;; strip trailing nulls from this list
	    (DO ((DT (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND) (CDR DT)))
		 ((OR (NULL DT)
		       (NOT (NULL (CAR DT))))
		   (UNLESS (NULL DT)
		     (SI:PUT-DEBUG-INFO-FIELD DBI :INTERNAL-FEF-NAMES (REVERSE DT)) )))
	    (SI:PUT-DEBUG-INFO-FIELD DBI :INTERNAL-FEF-OFFSETS
				     (MAKE-LIST (LENGTH (COMPILAND-CHILDREN COMPILAND)))) )
	  ;;store the offset of the continuation, if there was one
	  (let ((var (lookup-var '.next-method-list. (compiland-allvars compiland))))
		  (when (and var
			     (eq (var-kind var) 'fef-arg-key))
		   (si:put-debug-info-field
		    dbi :continuation-slot (cadr (var-lap-address var)))))
	  (UNLESS SUPPRESS-DEBUG
	    (LET ((SPECIALIZERS (GETF (COMPILAND-PLIST COMPILAND) 'TICLOS::SPECIALIZERS)))
	       (UNLESS (OR (NULL SPECIALIZERS)
			     (EQ (CAR-SAFE (COMPILAND-FUNCTION-NAME COMPILAND)) 'TICLOS:METHOD))
		  ;; Save for use by the disassembler -- function FUNCTION-SPECIALIZERS
		  (PUT-DEBUG-INFO-FIELD DBI 'ARG-CLASSES (MAPCAR #'TICLOS:TYPE-NAME SPECIALIZERS))))
	    ;; Include the local variable map.  It was built by ASSIGN-LAP-ADDRESSES.
	    (LET (( LOCAL-MAP (COMPILAND-LOCAL-MAP COMPILAND) ))
	      (DECLARE (UNSPECIAL LOCAL-MAP)(LIST LOCAL-MAP))
	      (UNLESS (OR (NULL LOCAL-MAP)
			  (EVERY #'NULL LOCAL-MAP))
		(SI:PUT-DEBUG-INFO-FIELD
		  DBI :LOCAL-MAP (COPY-TO-PROPER-AREA LOCAL-MAP))
		)))
	  (WHEN (OR (NOT SUPPRESS-ARGS) QUOTED-ARG SUBST-FLAG)
	    (SI:PUT-DEBUG-INFO-FIELD DBI :ARGLIST (COPY-TO-PROPER-AREA TRE-ARGS)))
	  (UNLESS SUPPRESS-DEBUG
	    ;; Include list of DEFCONSTANTs used, if any.
	    (UNLESS (NULL CONSTANTS-EXPANDED)
	      (SI:PUT-DEBUG-INFO-FIELD DBI :CONSTANTS-OPEN-CODED
				       (LOOP FOR TAIL ON CONSTANTS-EXPANDED BY #'CDDR
					     COLLECT (CONS (FIRST TAIL) (SECOND TAIL)))))
	    ;; Include list of macros used, if any.
	    (UNLESS (NULL MACROS-EXPANDED)
	      (SI:PUT-DEBUG-INFO-FIELD DBI :MACROS-EXPANDED
				       (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED))))
	  (LET* (( IND (INLINE-DECL FUNCTION-TO-BE-DEFINED) )
		 ( TRY-INLINE		   ; is this a candidate for inline expansion?
		  (OR (EQ IND 'compiler:INLINE)
		      (EQ IND 'compiler:TRY-INLINE)
		      (AND (NEQ IND 'compiler:NOTINLINE)
			   (< (COMPILAND-EXPRESSION-SIZE COMPILAND) 20.)
			   (OR (> (OPT-SPEED OPTIMIZE-SWITCH)
				  (OPT-SAFETY OPTIMIZE-SWITCH))
			       (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)
				    (EQ (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED)
					SI:PKG-LISP-PACKAGE)
				    (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED)))
			   (NOT MACROFLAG)
			   (TYPECASE FUNCTION-TO-BE-DEFINED
			     (NULL NIL)
			     (SYMBOL (AND (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED)
					  (NOT (GETL FUNCTION-TO-BE-DEFINED '(P1 P2 OPCODE)))))
			     (CONS (AND (EQ (FIRST FUNCTION-TO-BE-DEFINED) ':METHOD)
					(NEQ (THIRD FUNCTION-TO-BE-DEFINED) 'SI:FASLOAD-COMBINED)))
			     (T NIL))
			   (NOT (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND))
			   ) ) )
		 OLD-DEF )
	    (WHEN (AND QC-FILE-IN-PROGRESS
		       (NOT QC-FILE-LOAD-FLAG)
		       FUNCTION-TO-BE-DEFINED 
		       (OR TRY-INLINE
			   QUOTED-ARG
			   MACROFLAG
			   SUBST-FLAG
			   (IF (CONSP FUNCTION-TO-BE-DEFINED)
			       (AND (EQ (FIRST FUNCTION-TO-BE-DEFINED) :METHOD)
				    (NTHCDR 3 FUNCTION-TO-BE-DEFINED) )
			     (AND (COMPILAND-FLAVOR COMPILAND)
				  (COMPILAND-SELF-MAP-NEEDED COMPILAND)) )
			   (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)
				(FBOUNDP FUNCTION-TO-BE-DEFINED)
				(SETQ OLD-DEF (SYMBOL-FUNCTION FUNCTION-TO-BE-DEFINED))
				;; When a name that used to be a macro or subst is redefined
				;; as a function, need to remember the new definition in order
				;; to shadow the old one that is still in the global environment.
				(OR (EQ (CAR-SAFE OLD-DEF) 'MACRO)
				    (MEMBER (FIRST (INTERPRETED-DEF OLD-DEF))
					    '(GLOBAL:SUBST GLOBAL:NAMED-SUBST
							   CLI:SUBST NAMED-SUBST)
					    :TEST #'EQ)
				    (NOT (EQUAL (ARGLIST OLD-DEF 'LISP:COMPILE)
						TRE-ARGS)) ) )
			   )
		       ;; Was definition already saved by an (EVAL-WHEN (COMPILE)...)?
		       (not (equal (file-local-def function-to-be-defined) exp))
		       )
	      ;; Save definition for MACROEXPAND, MAYBE-INTEGRATE, P1ARGC, 
	      ;; CHECK-NUMBER-OF-ARGS, or EVAL-FOR-TARGET to use later in the file.
	      (setf (file-local-def function-to-be-defined)
		    ;; close over the compile-time environment
		    (FUNCTION-FOR-TARGET exp *COMPILE-FILE-ENVIRONMENT*) ))

	    (WHEN (OR SUBST-FLAG
		      TRY-INLINE
		      SAVE-INTERP-DEF
		      (AND (NOT (AND QC-FILE-IN-PROGRESS
				     (NOT QC-FILE-LOAD-FLAG)))
			   (NOT SUPPRESS-DEBUG)
			   ;; Don't save definition of generic functions or methods.
			   (NOT (LISTP FUNCTION-TO-BE-DEFINED))
			   (NOT (SI:GET-DEBUG-INFO-FIELD DBI :GENERIC-FUNCTION)) )
		      ;; Encapsulations must retain their interpreted definition to be able 
		      ;; to un-encapsulate later.
		      (SI:GET-DEBUG-INFO-FIELD DBI 'SYS:ENCAPSULATED-DEFINITION)
		      )
	      (SI:PUT-DEBUG-INFO-FIELD DBI :INTERPRETED-DEFINITION
				       (COPY-TO-PROPER-AREA EXP)) )
	    (WHEN UNDO-DECLARATIONS-FLAG
	      (LET (( KIND (COND (MACROFLAG "macro")
				 (QUOTED-ARG "special form")
				 (SUBST-FLAG 'DEFSUBST)
				 ((EQ IND 'compiler:INLINE) "inline function")
				 (T NIL)) ))
		(UNLESS (NULL KIND)
		  (CHECK-USED-BEFORE-DEFINED FUNCTION-TO-BE-DEFINED KIND))))
	  (WHEN SUBST-FLAG
	    (LET* (( DUMMY-FORM
		    (MULTIPLE-VALUE-BIND ( MIN MAX REST )
			(SI:ARGS-DESC EXP)
		      (DECLARE (IGNORE MIN))
		      (CONS 'FOO (MAKE-LIST (+ MAX (IF REST 1 0))
					    :INITIAL-ELEMENT '(GENSYM)))))
		   ( EXPANSION (SI:SUBST-EXPAND EXP DUMMY-FORM NIL)) )	   ; hard way
	      (UNLESS (EQUIVALENT-FORMS-P EXPANSION
					  (SI:SUBST-EXPAND EXP DUMMY-FORM T))   ; easy way
		;; If simple and thoughtful substitution give the same result
		;; even with the most intractable arguments,
		;; we need not use thoughtful substitution for this defsubst.
		;; Otherwise, mark it as requiring thoughtful substitution.
		(SI:PUT-DEBUG-INFO-FIELD DBI :NO-SIMPLE-SUBSTITUTION T) )))
	  ;; Compute the sxhash now, after all displacing macros have been displaced
	  (WHEN (AND (OR MACROFLAG SUBST-FLAG (EQ IND 'compiler:INLINE))
		     ;; allow hash code to be over-ridden by a DECLARE
		     (NULL (SI:GET-DEBUG-INFO-FIELD DBI :EXPR-SXHASH)))
	    (SI:PUT-DEBUG-INFO-FIELD DBI
				     :EXPR-SXHASH
				     (FUNCTION-EXPR-SXHASH (IF MACROFLAG (CDR EXP) EXP))) ))
	  (SETF (COMPILAND-DEBUG-INFO COMPILAND) DBI) )
      ))
 
(DEFUN COMPILER:WARN (TYPE SEVERITY FORMAT-STRING &REST ARGS)
  "Record and print a compiler warning.
TYPE describes the particular kind of problem, such as FUNCTION-NOT-VALID.
SEVERITY is a symbol in the keyword package giving a broader classification;
see the source for a list of possible severities.  FORMAT-STRING and ARGS
are used to print the warning."
  ;;  3/13/86 DNG - Bind TARGET-PROCESSOR to HOST-PROCESSOR to prevent recursive
  ;;		invocation from difficulties in EVAL-FOR-TARGET.
  ;; 10/30/89 DNG - New severity :NOT-PORTABLE.
  (IF WARN-CATCHER (THROW WARN-CATCHER 'WARN))
  (LET (( STATUS
	 (COND ((MEMBER SEVERITY
			'(:IMPLAUSIBLE :MISSING-DECLARATION :PROBABLE-ERROR
			  :OBSOLETE :NOT-PORTABLE :MACLISP :IGNORABLE-MISTAKE)
			:TEST #'EQ)
		WARNINGS)
	       ((EQ SEVERITY ':FATAL)  FATAL)
	       (T  ERRORS) ) ))
    (WHEN (< *RETURN-STATUS* STATUS) (SETQ *RETURN-STATUS* STATUS)) )
  
  (LET-UNLESS-CONSTANT (( *PRINT-CASE* ':UPCASE )
			( TARGET-PROCESSOR HOST-PROCESSOR ))
    (APPLY 'SI:RECORD-AND-PRINT-WARNING TYPE SEVERITY NIL FORMAT-STRING
	   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
	     ;; Copy temp area data only; note that ARGS lives in PDL-AREA.
	     ;; on error for nonexistent package refname.
	     (MAPCAR #'(LAMBDA (ARG)
			 (SI:COPY-OBJECT-TREE ARG T 12.))
		     ARGS)))))


))




#!C
; From file p1funs.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; p1funs.É#É"

			       
(DEFUN compiler:RECEIVE-CLOS-MAPS (LL)
  ;;  5/05/88 DNG - Original.
  ;;  5/09/88 DNG - Moved (PUSH VAR VARS) into MAKE-MAP-HOME .
  ;;  5/10/88 DNG - Warn about method args declared SPECIAL.
  ;;  5/23/88 CLM - Save the number of mapping-tables in a new field,
  ;;                  :MAP-SLOTS, in the debug-info.
  ;;  5/23/88 DNG - Use TICLOS::SPECIALIZERS declaration saved by PROCESS-PERVASIVE-DECLARATIONS.
  ;;  6/03/88 CLM - Changed to never delete the Continuation, even if not referenced later.
  ;; 11/22/88 DNG - Don't warn about special arguments whose class is T.
  ;;  4/28/89 DNG - Store class in both VAR-DATA-TYPE and VAR-DECLARATIONS.  
  ;;		Permit specializer name to be an anonymous class object.
  ;;  4/28/89 DNG - Don't warn about special arguments for any built-in class.
  ;;  5/05/89 DNG - Don't do CLASS-OF on an EQL form that has not yet been evaluated.
  ;;  5/08/89 DNG - Fix to not error on an argument declared type STREAM.
  (declare (special SYS:LOCAL-FOR-FIRST-MAPPING-TABLE  SYS:LOCALS-FOR-MAPPING-TABLE-BASE))
  (LET ((SPECIFIERS (OR (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'TICLOS::SPECIALIZERS)
			(LET ((FNAME (COMPILAND-FUNCTION-NAME *CURRENT-COMPILAND*)))
			  (AND (CONSP FNAME)
			       (EQ (CAR FNAME) 'TICLOS:METHOD)
			       (CAR (LAST FNAME)))))))
    (UNLESS (NULL SPECIFIERS)
      ;; This function is for a CLOS method.
      (LET ((SLOT-NUMBER SYS:LOCAL-FOR-FIRST-MAPPING-TABLE)
	    (count 0))
	(DO ((LL-TAIL LL (REST LL-TAIL))
	     (SPEC-TAIL SPECIFIERS (REST SPEC-TAIL)))
	    ((NULL SPEC-TAIL))
	  (WHEN (MEMBER (FIRST LL-TAIL) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
	    (SETQ LL-TAIL NIL))
	  (LET* ((ARG-NAME (FIRST LL-TAIL))
		 (CLASS-NAME (IF (TICLOS::INDIVIDUAL-TYPEP (FIRST SPEC-TAIL))
				 (LET ((EXP (TICLOS::INDIVIDUAL-TYPE (FIRST SPEC-TAIL))))
				   (DECLARE (NOTINLINE SELF-EVALUATING-P TICLOS:CLASS-OF)) ; don't need speed here.
				   (IF (OR QC-FILE-LOAD-FLAG (SELF-EVALUATING-P EXP))
				       (TICLOS:CLASS-OF EXP)
				     ;; Else the form may not have been evaluated yet.
				     'T))
			       (FIRST SPEC-TAIL)))
		 (MAP-VAR (MAKE-MAP-HOME (IF (OR (NULL ARG-NAME)
						 (NULL (SYMBOL-PACKAGE ARG-NAME)))
					     (GENSYM)
					   (INTERN (STRING-APPEND "map for " ARG-NAME)))
					 SLOT-NUMBER)))
	    (UNLESS (NULL ARG-NAME)
	      (LET ((VAR (LOOKUP-VAR ARG-NAME VARS)))
		(WHEN (AND (EQ (VAR-TYPE VAR) 'FEF-SPECIAL)
			   (NOT (TYPEP (TICLOS:CLASS-NAMED CLASS-NAME T *COMPILE-FILE-ENVIRONMENT*)
				       'TICLOS:BUILT-IN-CLASS)))
		  (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			"Method argument ~S is special; this will prevent optimization of slot accesses."
			ARG-NAME))
		(SETF (GETF (VAR-DECLARATIONS VAR) 'MAPPING-TABLE) MAP-VAR)
		(LET ((DECLARED-TYPE (VAR-DATA-TYPE VAR)))
		  (COND ((NOT (OR (EQ DECLARED-TYPE CLASS-NAME)
				  (SUBTYPEP DECLARED-TYPE CLASS-NAME *COMPILE-FILE-ENVIRONMENT*)
				  (SUBTYPEP CLASS-NAME DECLARED-TYPE *COMPILE-FILE-ENVIRONMENT*)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S DECLAREd type ~S, inconsistent with specializer ~S."
			       ARG-NAME DECLARED-TYPE (FIRST SPEC-TAIL)))
			((AND (EQ CLASS-NAME 'T)
			      (SYS:CLASSP DECLARED-TYPE)
			      (NOT (TYPEP (TICLOS:CLASS-NAMED DECLARED-TYPE T *COMPILE-FILE-ENVIRONMENT*)
					  'TICLOS:BUILT-IN-CLASS)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S has been DECLAREd to be of type ~S, so
you might as well say that it is specialized on that class, which will enable
more efficient code to be generated for slot accesses."
			      ARG-NAME (TICLOS:CLASS-PROPER-NAME DECLARED-TYPE)))))
		(SETF (VAR-DATA-TYPE VAR) CLASS-NAME)
		(SETF (GETF (VAR-DECLARATIONS VAR) 'TYPE) CLASS-NAME)
		)))
	  (SETQ SLOT-NUMBER (MAX SYS:LOCALS-FOR-MAPPING-TABLE-BASE
				 (1+ SLOT-NUMBER)))
	  (incf count)
	  )					; end DO
	(LET ((VAR  (MAKE-MAP-HOME '.NEXT-METHOD-LIST. SLOT-NUMBER)))
	  (SETF (VAR-KIND VAR) 'FEF-ARG-KEY) ; never delete* (old - delete if not referenced later)
	  ;;add new field to debug-info list indicating number of mapping-tables
	  (push `(:map-slots . ,count) (compiland-debug-info *current-compiland*))
	  )
	)))
  (VALUES))
 


(DEFUN COMPILER:P1 (ORIGINAL-FORM &OPTIONAL DONT-OPTIMIZE)
  "Pass 1 compilation of a single Lisp form."
  ;; 12/27/84 - Improve EXPRESSION-SIZE update.
  ;; 12/28/84 - Don't increment use count of ignored variable.
  ;; 12/29/84 - Do increment use count of propagated variable.
  ;;  1/19/85 - NOTINLINE declaration forces call instead of 
  ;;		machine instruction and prevents DEFSUBST expansion.
  ;;  1/23/85 - Add check for cold load files.
  ;;  1/24/85 - Add use of P1-WITH-ANNOTATION.
  ;;  2/20/85 - Suppress constant folding on dead code.
  ;;  8/27/85 - Suprress T.R.E. on function defined by Misc-op.
  ;;  2/21/86 - Enable first arg of FUNCALL to be ephemeral closure.
  ;;  5/07/86 - Do NIL ==> (QUOTE NIL) without consing.
  ;;  6/16/86 - Check for higher level lexical variable before DEFCONSTANT to
  ;;		allow local shadowing with UNSPECIAL declaration. [SPR 2413]
  ;;  6/20/86 - Call EXPAND-LAMBDA directly instead of using P1LAMBDA.
  ;;  6/25/86 - Fix to handle (FUNCALL '#<DTP-FUNCTION ...> ...).
  ;;  7/02/86 - Change handling of non-local lexical variables.
  ;;  7/10/86 - Set SPECIAL-VAR-BIT in USED-VAR-SET on reference to free
  ;;		special variable; provide for inline expansion of local functions.
  ;;  7/17/86 - Allow inline expansion of local functions.
  ;;  7/25/86 - More changes for non-local variables.
  ;;  8/28/86 - Call to p1argc no longer passes result of getargdesc - just pass form
  ;;  9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.
  ;;  9/15/86 - Call MAYBE-INTEGRATE after POST-OPTIMIZE instead of before.
  ;;  9/16/86 - Record side-effects for arbitrary function calls.
  ;;  9/18/86 - Use FIX-FUNCALL-EVALUATION-ORDER on FUNCALL forms.
  ;;  9/20/86 - Add special handling for COMPILER-LET.
  ;;  9/24/86 - Pass saved ALLVARS as second arg to FIX-FUNCALL-EVALUATION-ORDER .
  ;; 10/18/86 - Permit tail recursion elimination of local functions.
  ;; 11/14/86 - Don't count BLOCK-FOR-PROG in EXPRESSION-SIZE.
  ;;  7/07/87 - Special handling for constants evaluated at load time. [SPR 4918]
  ;;  9/28/87 - Modified for Scheme. [Not included in this file until 3/15/89.]
  ;; 10/02/87 - Tail Recursion Elimination is always enabled in Scheme mode.
  ;;		Don't add special variable to FREEVARS when value is not being used.
  ;; 10/14/87 - Fixed bug in 9/28 change.
  ;; 11/14/87 - Add support for SCHEME:DEFINE-INTEGRABLE .
  ;;		Permit a FEF object to appear as the CAR of a form.
  ;; 11/21/87 - Permit keywords to be used as variable names in Scheme mode.
  ;; 12/19/87 - Fix use of symbol defined by SCHEME:DEFINE-INTEGRABLE in 
  ;;		function position.  Inline expansion of FUNCALL of a breakoff
  ;;		function.  Modified to facilitate tail recursion elimination on LETREC functions.
  ;;  1/09/88 - Add use of SCHEME:PCS-INTEGRATE-T-AND-NIL.
  ;;  2/10/88 - Add inherited vars argument to TAIL-RECURSION-ELIMINATION. [SPR 7113]
  ;; 12/16/88 - Fix to not optimize (FUNCALL 'symbol ...) when it has the same 
  ;;		name as a local function.
  ;;  4/22/89 - Update and uncomment the support for PCS-INTEGRATE-T-AND-NIL.
  ;;  4/25/89 - Add setting of COMPILAND-CONSTANTS-EXPANDED for SPR 6501.
  ;;  6/23/89 DNG - Fix optimization of (FUNCALL '#<DTP-FUNCTION > ...) so 
  ;;		that it correctly handles the possibility of the new call optimizing
  ;;		into a special form, such as QUOTE.  [SPR 10132]
  ;; 10/31/89 DNG - Add use of CHECK-CONFORMANCE and CHECK-CONSTANT-PORTABILITY .
  (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 2)))
  (LET (FORM TM NEW-SIZE NEW-FORM INDECL HANDLER)
    (IF (ATOM ORIGINAL-FORM)
	(SETQ FORM ORIGINAL-FORM)
      (IF (AND (COMPILING-SCHEME-P)
	       (TYPECASE (CAR ORIGINAL-FORM)
		 ( SYMBOL (IF (LOOKUP-VAR (CAR ORIGINAL-FORM) VARS)
			      (NOT (ASSOC (CAR ORIGINAL-FORM) LOCAL-FUNCTIONS :TEST #'EQ))
			    (NOT (OR (FBOUNDP (CAR ORIGINAL-FORM))
				     (EQ (GET (CAR ORIGINAL-FORM) 'INTEGRABLE '|<Undefined>|)
					 '|<Undefined>|)))) )
		 ( CONS (NOT (MEMBER (CAAR ORIGINAL-FORM) SI:FUNCTION-START-SYMBOLS :TEST #'EQ)))
		 ( T T)))
	  (SETQ FORM (CONS 'FUNCALL ORIGINAL-FORM))
	(PROGN
	  (WHEN (ATOM (CAR ORIGINAL-FORM))
	    (SETQ INDECL (INLINE-DECL (CAR ORIGINAL-FORM))) )
	  (SETQ FORM (PRE-OPTIMIZE ORIGINAL-FORM T
				   (OR DONT-OPTIMIZE
				       (AND (EQ INDECL 'NOTINLINE)
					    (NULL (GETL (CAR ORIGINAL-FORM)
							'(P1 P2))) ) ) ))
	  (WHEN (AND (NOT (EQ FORM ORIGINAL-FORM))
		     (CONSP FORM)
		     (NOT (SYMBOLP (CAR FORM)))
		     (COMPILING-SCHEME-P))
	    (SETQ FORM (CONS 'FUNCALL FORM)))
	  ) ) )
    (SETQ NEW-SIZE (+ EXPRESSION-SIZE 1-IF-LIVE-CODE))
    (COND
      ((ATOM FORM)
       (SETQ EXPRESSION-SIZE NEW-SIZE)
       (RETURN-FROM P1
	 (COND ((EQ FORM 'NIL) '(QUOTE NIL)) ; avoid consing for this common special case
	       ((EQ FORM 'T)   '(QUOTE T))
	       ((OR (NOT (SYMBOLP FORM))
		    (AND (KEYWORDP FORM) (NOT (COMPILING-SCHEME-P))))
		;; constant other than a DEFCONSTANT
		(WHEN CHECK-CONFORMANCE
		  (CHECK-CONSTANT-PORTABILITY FORM))
		(LIST 'QUOTE FORM))
	       ((SETQ TM (LOOKUP-VAR FORM VARS)) ; found in table of local variables
		(IF (AND (NOT P1VALUE) (NOT DONT-OPTIMIZE))
		    ;; The value is not being used, so the reference is
		    ;; expected to be deleted by later optimizations.
		    ;; Don't increment the variable's use count and just
		    ;; return a dummy placeholder.
		    (PROGN (WHEN (NULL (VAR-USE-COUNT TM))
			     (SETF (VAR-USE-COUNT TM) 0))
			   '(QUOTE |<unused_var>|))
		  (PROGN ; a genuine variable reference
		    (SETQ NEW-FORM (VAR-LAP-ADDRESS TM))
		    (IF (AND (CONSP NEW-FORM)
			     (EQ (CAR NEW-FORM) 'LOCAL-REF))
			(IF (AND (LOGTEST (CDDR NEW-FORM) PROPAGATE-VAR-SET)
				 PROPAGATE-ENABLE )
			    (PROGN (SETQ NEW-FORM (VAR-INIT-FORM TM))
				   (COND ((NULL NEW-FORM)
					  (SETQ NEW-FORM '(QUOTE NIL)))
					 ((ATOM NEW-FORM))
					 ((EQ (CAR NEW-FORM) 'LOCAL-REF)
					  (VAR-INCREMENT-USE-COUNT (SECOND NEW-FORM))
					  (SETQ USED-VAR-SET
						(LOGIOR USED-VAR-SET (CDDR NEW-FORM))))
					 ((EQ (CAR NEW-FORM) 'BREAKOFF-FUNCTION)
					  (INCF (COMPILAND-USE-COUNT (SECOND NEW-FORM))))
					 (T (DEBUG-ASSERT (NO-SIDE-EFFECTS-P NEW-FORM))))
				   (WHEN (NULL (VAR-USE-COUNT TM))
				     (SETF (VAR-USE-COUNT TM) 0))
				   (RETURN-FROM P1 NEW-FORM))
			  (PROGN
			    (UNLESS (OR (NULL *VAR-LEVEL-COUNTS*)
					(ZEROP 1-IF-LIVE-CODE))
			      (LET (( VC (VAR-COMPILAND TM) ))
				(UNLESS (EQ VC *CURRENT-COMPILAND*)
				  (INCF (NTH (COMPILAND-NESTING-LEVEL VC)
					     *VAR-LEVEL-COUNTS*)
					(LOOP-WEIGHTED-INCREMENT *LOOP-LEVEL*)
				    ))))
			    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW-FORM)))
			    ))
		      (WHEN (SYMBOLP NEW-FORM)
			(WHEN (OR (EQ (VAR-KIND TM) 'FEF-ARG-FREE)
				  (NEQ (VAR-COMPILAND TM) *CURRENT-COMPILAND*))
			  (UNLESS (ZEROP 1-IF-LIVE-CODE)
			    (PUSHNEW NEW-FORM FREEVARS :TEST 'EQ) ) )
			(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))))
		    (VAR-INCREMENT-USE-COUNT TM)
		    NEW-FORM) ))
	       ((AND SELF-FLAVOR-DECLARATION
		     (TRY-REF-SELF FORM)))
	       ((AND (COMPILING-SCHEME-P)
		     (OR (FBOUNDP FORM)
			 (UNLESS (EQ (SETQ TM (GET FORM 'INTEGRABLE '|<Undefined>|))
				     '|<Undefined>|)
			   (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ)
			   (RETURN-FROM P1 (P1 TM DONT-OPTIMIZE)))
			 (WHEN (EQ (SYMBOL-PACKAGE FORM) *KEYWORD-PACKAGE*)
			   (RETURN-FROM P1 (LIST 'QUOTE FORM)))
			 (NOT (SPECIALP FORM T))))
		(LOCALLY ;; The values of the these are assigned when the Scheme system is loaded.
		  (declare (special PCS-INTEGRATE-T-AND-NIL SCHEME-T SCHEME-NIL))
		  (COND ((AND (EQ FORM SCHEME-T) PCS-INTEGRATE-T-AND-NIL)
			 '(QUOTE T))
			((AND (EQ FORM SCHEME-NIL) PCS-INTEGRATE-T-AND-NIL)
			 '(QUOTE NIL))
			(T (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			     (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))
			   `(FUNCTION ,FORM)))))
	       ((BLOCK CONSTANT?
		  (AND (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
		       (NOT DONT-OPTIMIZE)
		       (LET ( CONST )
			 (COND ((SETQ CONST (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ))
				(SETQ TM (CDR CONST)) )
			       ((AND (SETQ CONST (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT))
				     (NOT (EQ CONST 'COMPILER:QC-PROCESS-INITIALIZE))
				     ;; DEFCONSTANT, not a machine-dependent constant
				     (BOUNDP-FOR-TARGET FORM))
				(SETQ TM (SYMEVAL-FOR-TARGET FORM)) )
			       (T (RETURN-FROM CONSTANT? NIL)) )
			 (OR (NUMBERP TM)
			     (SYMBOLP TM)
			     (CHARACTERP TM) ) ) ) )
		(SETF (GETF (COMPILAND-CONSTANTS-EXPANDED *CURRENT-COMPILAND*) FORM) TM)
		(LIST 'QUOTE TM))
	       (T (IF P1VALUE
		      (PROGN (MAKESPECIAL FORM)
			     (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			       (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT))))
		    (LET ((FREEVARS FREEVARS)) 
		      (MAKESPECIAL FORM)))
		  FORM))))
      ((EQ (CAR FORM) 'QUOTE)
       (SETQ EXPRESSION-SIZE NEW-SIZE)
       (WHEN (AND CHECK-CONFORMANCE (IN-SOURCE-AREA-P FORM))
	 (CHECK-CONSTANT-PORTABILITY (SECOND FORM)))
       (RETURN-FROM P1 (IF (AND QC-FILE-IN-PROGRESS
				(NOT QC-FILE-LOAD-FLAG)
				(CONSP (SECOND FORM))
				(LOAD-TIME-EVAL-P (SECOND FORM) 0) )
			   `(QUOTE-LOAD-TIME-EVAL ,FORM) ; hide the value from optimization
			 FORM)))
      ;; Certain constructs must be checked for here
      ;; so we can call P1 recursively without setting TLEVEL to NIL.
      ((NOT (ATOM (CAR FORM)))
       (LET ((FCTN (CAR FORM)))
	 (UNLESS (SYMBOLP (CAR FCTN))
	   (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE
		 "There appears to be a call to a function whose CAR is ~S."
		 (CAR FCTN)))
	 (COND ((MEMBER (CAR FCTN)
			'(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA CLI:LAMBDA NAMED-LAMBDA)
			:TEST #'EQ)
		;;added extra arg to expand lambda to indicate that args not processed
		(RETURN-FROM P1
		  (P1 (EXPAND-LAMBDA FCTN (CDR FORM) NIL nil)) ))
	       (T ;; Old Maclisp evaluated functions.
		(WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE
		      "The expression ~S is used as a function; use FUNCALL."
		      (CAR FORM))
		(RETURN-FROM P1 (P1 `(FUNCALL . ,FORM)))))))
      ((NOT (SYMBOLP (CAR FORM)))
       (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE
	     "~S is used as a function to be called." (CAR FORM))
       (RETURN-FROM P1 (P1 (CONS 'PROGN (CDR FORM)))))
      )
    (SETQ NEW-FORM
	  (COND
	    ((SETQ TM (ASSOC (CAR FORM) LOCAL-FUNCTIONS :TEST #'EQ))
	     ;; local function defined by FLET or LABELS
	     (SETQ NEW-FORM (P1EVARGS FORM))
	     (SETQ EXPRESSION-SIZE NEW-SIZE)
	     (OR (AND (EQ (COMPILAND-DEFINITION *CURRENT-COMPILAND*)
			  (THIRD TM)) ; function is calling itself
		      (CONSP P1VALUE)
		      (LET ((X (ASSOC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)
				      P1VALUE :TEST #'EQ)))
			(AND X ; this is a tail recursive call
			     (MEMBER X TRE-OK :TEST #'EQ) ; no special bindings in effect
			     (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
			     (SECOND X) ; loop-back tag provided
			     (NOT DONT-OPTIMIZE)
			     (TAIL-RECURSION-ELIMINATION
			       NEW-FORM (SECOND X) (THIRD X) (FIFTH X)) )))
		 `(FUNCALL ,(REF-LOCAL-FUNCTION-VAR (SECOND TM))
			   . ,(CDR NEW-FORM)) ))
	    ((MEMBER (CAR FORM) '(LET LET*) :TEST #'EQ)
	     (P1-WITH-ANNOTATION FORM #'P1LET 'UNKNOWN DONT-OPTIMIZE))
	    ((EQ (CAR FORM) 'BLOCK)
	     (P1-WITH-ANNOTATION FORM #'P1BLOCK 'UNKNOWN DONT-OPTIMIZE))
	    ((EQ (CAR FORM) 'TAGBODY)
	     (P1-WITH-ANNOTATION FORM #'P1TAGBODY 'NULL DONT-OPTIMIZE))
	    ((EQ (CAR FORM) '%POP) FORM )	;P2 specially checks for this
	    ((EQ (CAR FORM) 'COMPILER-LET)
	     ;; handled specially here so that the result will not be re-optimized
	     ;; after the bindings are un-done.
	     (RETURN-FROM P1
	       (SI:EVAL1 `(COMPILER-LET ,(SECOND FORM)
			    (P1 '(PROGN . ,(CDDR FORM))) ))))
	    ((SETQ TLEVEL NIL))
	    ((EQ (CAR FORM) 'COND)
	     (P1-WITH-ANNOTATION FORM #'P1COND 'UNKNOWN DONT-OPTIMIZE))
	    ;; Check for functions with special P1 handlers.
	    ((AND (SETQ HANDLER (GET (CAR FORM) 'P1))
		  (OR (NEQ INDECL 'NOTINLINE)
		      (NOT (MEMBER HANDLER '(P1SIMPLE P1-DOWNWARD-FUNARG
					     P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ))) )
	     (UNLESS (MEMBER (CAR FORM)
			     '( PROGN IGNORE P1-HAS-BEEN-DONE RETURN-FROM %BLOCK-BODY
			        #+compiler:debug P1-ALREADY-DONE ; this one is obsolete 9/19/86
				COMPILER-LET BLOCK-FOR-PROG
				)
			     :TEST #'EQ)
	       (SETQ EXPRESSION-SIZE NEW-SIZE) )
	     (FUNCALL HANDLER FORM))
	    ((AND ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH
		  (LOOKUP-VAR (CAR FORM) VARS)
		  (NULL (FUNCTION-P (CAR FORM))))
	     (WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE
		   "The variable ~S is used in function position; use FUNCALL."
		   (CAR FORM))
	     (RETURN-FROM P1 (P1 (CONS 'FUNCALL FORM))))
	    ((EQ (CAR FORM) 'FUNCALL)
	     (SETQ TM (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
	     (LET (( F (LET (( P1VALUE 'DOWNWARD-ONLY ))
			 (P1 (SECOND FORM)) )))
	       (COND ((AND (CONSP F)
			   (MEMBER (FIRST F) '(QUOTE FUNCTION) :TEST #'EQ)
			   (NOT DONT-OPTIMIZE)
			   (OR (SYMBOLP (SECOND F))
			       (CONSP (SECOND F)))
			   (NOT (ASSOC (SECOND F) LOCAL-FUNCTIONS :TEST #'EQUAL)) ; 12/16/88
			   (FUNCTIONP (SECOND F)) )
		      ;; (FUNCALL #'f a b) ==> (f a b)
		      ;; (FUNCALL #'(LAMBDA ...) a b) ==> ((LAMBDA ...) a b)
		      (RETURN-FROM P1 (P1 (CONS (SECOND F) (CDDR FORM)))))
		     ((AND (QUOTEP F)
			   (FUNCTIONP (SECOND F) NIL)
			   (SYMBOLP (SETQ TM (FUNCTION-NAME (SECOND F))))
			   (FBOUNDP TM)
			   (EQ (SYMBOL-FUNCTION TM) (SECOND F))
			   (NOT DONT-OPTIMIZE)
			   (EXTERNAL-SYMBOL-P TM))
		      ;; ('#<DTP-FUNCTION fn ...> a b)  ==> (fn a b)
		      ;; This idiom is used by some Scheme macros to ensure access to the 
		      ;; global definition.
		      (SETQ EXPRESSION-SIZE NEW-SIZE)
		      (SETQ FORM (PRE-OPTIMIZE (CONS TM (CDDR FORM))
					       T (EQ (SETQ INDECL (GET TM 'INLINE)) 'NOTINLINE)))
		      (COND ((ATOM FORM) FORM)
			    ((SPECIAL-FORM-P (CAR FORM))
			     (RETURN-FROM P1 (P1 FORM)))
			    (T (FUNCALL (SETQ HANDLER (GET (CAR FORM) 'P1 'P1ARGC)) FORM)))
		      )
		     (T (SETQ EXPRESSION-SIZE NEW-SIZE)
			(WHEN (AND (MEMBER (CAR-SAFE F) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))
				   (EQ (SECOND F) (FIRST (COMPILAND-CHILDREN *CURRENT-COMPILAND*)))
				   (EQ TM (REST (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))
			  ;; Encourage PROCEDURE-INTEGRATION.
			  (SETF (GETF (COMPILAND-PLIST (SECOND F)) 'USED-ONLY-ONCE) T))
			(PROG1 (LET ((SAVE-ALLVARS ALLVARS))
				 (FIX-FUNCALL-EVALUATION-ORDER
				   (CONS 'FUNCALL (P1EVARGS (CONS F (CDDR FORM))))
				   SAVE-ALLVARS))
			       (ARBITRARY-SIDE-EFFECTS))) )) )
	    ( T	  ; general function
	     (SETQ EXPRESSION-SIZE NEW-SIZE)
	     (UNLESS (NULL (CDR FORM))
	       (SETQ FORM (P1ARGC FORM ) ))
	     (COND
	       ((AND (CONSP P1VALUE)  ; still has initial value from QCOMPILE1
		     (SETQ TM (ASSOC (CAR FORM) P1VALUE :TEST #'EQ))
						; this is a tail recursive call
		     (OR (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0) ; user permits optimizing
			 (COMPILING-SCHEME-P))	; Scheme users expect this to happen.
		     (MEMBER TM TRE-OK :TEST #'EQ)	 ; no special bindings in effect
		     TRE-ENABLE 
		     (NOT DONT-OPTIMIZE)
		     (NOT (GETL (CAR FORM)
				'(P2 OPCODE))) ; not expanded by pass 2
		     (TAIL-RECURSION-ELIMINATION
		       FORM (SECOND TM) (THIRD TM) (FIFTH TM) ) ))
	       ((AND (SETQ TM (ASSOC (CAR FORM) INLINE-EXPANSIONS :TEST #'EQ))
		     (NEQ (FIRST TM) (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) )
		;; This is a recursive call to a function which we are
		;;   currently in the process of expanding inline.
		;; Abort the inline expansion.
		(THROW (SECOND TM) 'RECURSIVE) ); the CATCH is in function PROCEDURE-INTEGRATION
	       ((AND (EQ INDECL 'NOTINLINE)
		     (EQ (CAR ORIGINAL-FORM) (CAR FORM)) )
		(SETQ DONT-OPTIMIZE INDECL)
		(ARBITRARY-SIDE-EFFECTS)
		(IF (AND (GET (CAR FORM) 'P2)
			 (FUNCTIONP (CAR FORM)) )
		    `(FUNCALL (FUNCTION ,(CAR FORM)) . ,(CDR FORM))
		  FORM) )
	       (T (SETQ HANDLER 'P1ARGC)
		  FORM) )
	    )))
    ;; Apply post-optimizations
    (UNLESS (OR DONT-OPTIMIZE
		;; Don't optimize dead code -- not only to avoid
		;; wasting time, but because constant folding could
		;; get an argument type error which would be irrelevant.
		(ZEROP 1-IF-LIVE-CODE))
      (SETQ TM (POST-OPTIMIZE NEW-FORM))
      (WHEN (AND (MEMBER HANDLER '(P1ARGC P1-DOWNWARD-FUNARG P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ)
		 (OR (EQ TM NEW-FORM)
		     (NOT (TRIVIAL-FORM-P TM))))
	;; possibility of inline expansion of the called function
	(SETQ FORM (IF (OR (EQ (CAR ORIGINAL-FORM) (CAR TM))
			   (EQ INDECL 'INLINE))
		       (MAYBE-INTEGRATE (CAR TM) (CDR TM) NIL INDECL)
		     (MAYBE-INTEGRATE (CAR TM) (CDR TM)) ))
	(UNLESS (NULL FORM)
	  (SETQ TM (POST-OPTIMIZE FORM))
	  (SETQ HANDLER NIL)))
      (WHEN (NEQ NEW-FORM TM)
	(SETQ HANDLER NIL) ; don't update var sets below
	(SETQ NEW-FORM TM)
	(WHEN (TRIVIAL-FORM-P NEW-FORM)
	  ;; optimized down to just a constant or variable --
	  ;; count its size as only 1
	  (SETQ EXPRESSION-SIZE NEW-SIZE)
      ) ) )
    (WHEN (AND INLINE-EXPANSIONS
	       (> EXPRESSION-SIZE EXPRESSION-SIZE-LIMIT) )
      ;; inline expansion of function call has become too big 
      ;;  to be desirable -- abort back to CATCH in
      ;;  function PROCEDURE-INTEGRATION
      (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'SIZE) )
    (WHEN (EQ HANDLER 'P1ARGC)
      (BLOCK USE-SPECIAL
	(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
	  (WHEN (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM))
	    (RETURN-FROM USE-SPECIAL))
	  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET GLOBAL-SIDE-EFFECTS)))
	(UNLESS (OR (LOGTEST DATA-ALTERATION-BIT ALTERED-VAR-SET)
		    (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM)))
	  (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET GLOBAL-SIDE-EFFECTS)))))
    (WHEN (AND SI:FILE-IN-COLD-LOAD ; Current file has attribute COLD-LOAD:T
	       (CONSP NEW-FORM)
	       (NOT (ZEROP 1-IF-LIVE-CODE))
	       (NOT (AND (SYMBOLP (FIRST NEW-FORM))
			 (GETL (FIRST NEW-FORM) '(P2 OPCODE)))) )
      (CHECK-COLD (FIRST NEW-FORM)) )
    (RETURN-FROM P1 NEW-FORM)
    ))

(DEFUN compiler:EXPAND-KEYED-LAMBDA (LAMBDA-EXP)
  ;; 12/11/85 DNG - Fix to not lose local SPECIAL declaration for keyword args.
  ;;  6/18/86 DNG - Remove obsolete code for creating ARGLIST declaration [now
  ;;		handled in SET-UP-DEBUG-INFO]; avoid using the macro WHEN in the
  ;;		expansion.
  ;;  8/08/86 DNG - Deleted use of LEXICAL-VAR-P.
  ;;  9/03/86 DNG - Fix handling of type and IGNORE declarations for keyword args.
  ;;  9/16/86 DNG - Don't use KEYWORD-GARBAGE when initial value is a FUNCTION form.
  ;; 10/11/86 DNG - Don't use KEYWORD-GARBAGE when initial value is a special variable.
  ;; 10/17/86 DNG - Give warning on non-keyword keyword, eg (&key ((wrong nm))).
  ;; 11/23/87 DNG - Add special handling for &KEY not followed by any 
  ;;		arguments to avoid generating bad code. [SPR 6956.]
  ;;  9/19/88 DNG - Move binding of KEYFLAGS to the second LET* so they don't 
  ;;		get marked as FEF-ARG-KEY.  Change warning to permit non-keyword symbols 
  ;;		in KEYKEYS.
  ;;  8/09/89 DNG - Add UNSPECIAL declaration for REST-ARG.
  ;; 11/02/89 DNG - Add check for &KEY followed by &REST [SPR 9282] or &OPTIONAL.
  
  (LET (LAMBDA-LIST BODY
	MAYBE-REST-ARG KEYCHECKS
	POSITIONAL-ARGS AUXVARS REST-ARG POSITIONAL-ARG-NAMES
 	KEYKEYS KEYNAMES KEYINITS KEYFLAGS ALLOW-OTHER-KEYS
	PSEUDO-KEYNAMES DECLS)
    (DECLARE (LIST POSITIONAL-ARGS AUXVARS POSITIONAL-ARG-NAMES
		   KEYKEYS KEYNAMES KEYINITS KEYFLAGS))
    (DECLARE (UNSPECIAL REST-ARG)) ; special in QLAPP
    (COND ((MEMBER (CAR LAMBDA-EXP) '(GLOBAL:LAMBDA CLI:LAMBDA) :TEST #'EQ)
	   (SETQ LAMBDA-LIST (CADR LAMBDA-EXP) BODY (CDDR LAMBDA-EXP)))
	  (T
	   (SETQ LAMBDA-LIST (CADDR LAMBDA-EXP) BODY (CDDDR LAMBDA-EXP))))
    (MULTIPLE-VALUE-SETQ (POSITIONAL-ARGS NIL AUXVARS REST-ARG POSITIONAL-ARG-NAMES
			  KEYKEYS KEYNAMES NIL KEYINITS KEYFLAGS ALLOW-OTHER-KEYS)
			 (DECODE-KEYWORD-ARGLIST LAMBDA-LIST))
    (LET ((AFTER (CDR (MEMBER '&KEY LAMBDA-LIST))))
      (WHEN (MEMBER '&OPTIONAL AFTER)
	(CONFORMANCE-WARNING "~S following ~S is not valid." '&OPTIONAL '&KEY))
      (WHEN (MEMBER '&REST AFTER)
	(WARN '&REST ':IMPOSSIBLE "~S following ~S is not valid." '&REST '&KEY))) 
    (DOLIST (KK KEYKEYS)
      (UNLESS (SYMBOLP KK)
	(WARN 'KEYKEYS ':IMPLAUSIBLE
	      "~S should be a symbol in ~S" KK (MEMBER '&KEY LAMBDA-LIST))))
    (SETQ PSEUDO-KEYNAMES (COPY-LIST KEYNAMES))
    ;; For each keyword arg, decide whether we need to init it to KEYWORD-GARBAGE
    ;; and check explicitly whether that has been overridden.
    ;; If the arg is optional
    ;; and the initial value is a constant, we can really init it to that.
    ;; Otherwise we create a dummy variable initialized to KEYWORD-GARBAGE;
    ;; after all keywords are decoded, we bind the intended variable, in sequence.
    ;; However a var that can shadow something (including any special var)
    ;; must always be replaced with a dummy.
    (DO ((KIS KEYINITS (CDR KIS))
	 (KNS KEYNAMES (CDR KNS))
	 (PKNS PSEUDO-KEYNAMES (CDR PKNS))
	 (KFS KEYFLAGS (CDR KFS)))
	((NULL KNS))
      (LET ((KEYNAME (CAR KNS)) PSEUDO-KEYNAME
	    (KEYFLAG (CAR KFS)) (KEYINIT (CAR KIS)))
	(UNLESS (AND (NULL KEYFLAG)
		     (OR (CONSTANTP KEYINIT)
			 (EQ (CAR-SAFE KEYINIT) 'FUNCTION)
			 (AND (SYMBOLP KEYINIT)
			      (NULL KEYCHECKS)
			      (BOUNDP KEYINIT)))
		     (NOT (LOOKUP-VAR KEYNAME VARS))
		     (NOT (SPECIALP KEYNAME)))
	  (SETF (CAR KIS) 'SI:KEYWORD-GARBAGE)
	  (SETQ PSEUDO-KEYNAME (GENSYM))
	  (SETF (CAR PKNS) PSEUDO-KEYNAME)
	  (PUSH `(,KEYNAME
		  (COND ((EQ ,PSEUDO-KEYNAME SI:KEYWORD-GARBAGE)
			 ,KEYINIT)
			(T ,(AND KEYFLAG `(SETQ ,KEYFLAG T))
			   ,PSEUDO-KEYNAME)))
		KEYCHECKS))))
    (SETQ KEYFLAGS (REMOVE NIL (THE LIST KEYFLAGS) :TEST #'EQ))
    (SETQ KEYCHECKS (NREVERSE KEYCHECKS))
    (WHEN (EQ (CAR-SAFE (FIRST BODY)) 'DECLARE)
      ;; Note: we don't need the generality of PARSE-BODY here because QCOMPILE1
      ;; has already extracted the documentation and collected all declarations
      ;; into a single DECLARE form.
      (SETQ DECLS (REST (FIRST BODY)))
      (SETQ BODY (REST BODY)))
    ;; If the user didn't ask for a rest arg, make one for the
    ;; outer function anyway.
    (UNLESS REST-ARG
      (SETQ REST-ARG (GENSYM)
	    MAYBE-REST-ARG (LIST '&REST REST-ARG)))
    `(LAMBDA (,@POSITIONAL-ARGS ,@MAYBE-REST-ARG)
       (DECLARE (.ARG.) . ,DECLS)
       (LET* (,@(MAPCAR #'LIST PSEUDO-KEYNAMES KEYINITS))
	 (DECLARE (.AUX.) . ,DECLS)
	 (AND ,REST-ARG
	      ,(IF (NULL PSEUDO-KEYNAMES) ; no actual key arguments
		   (IF ALLOW-OTHER-KEYS
		       'NIL ; don't have to do anything
		     `(SI:STORE-KEYWORD-ARG-VALUES (%STACK-FRAME-POINTER) ,REST-ARG () NIL NIL))
		 ;; Else normal case
		 `(SI:STORE-KEYWORD-ARG-VALUES (%STACK-FRAME-POINTER)
					       ,REST-ARG ',KEYKEYS
					       ,ALLOW-OTHER-KEYS
					       (VARIABLE-LOCATION ,(CAR PSEUDO-KEYNAMES))) ))
	 (LET* ,(NCONC KEYFLAGS KEYCHECKS AUXVARS)
	   (DECLARE (.AUX.) . ,DECLS)
	   . ,BODY)))))

(DEFUN compiler:PRE-OPTIMIZE (FORM CHECK-STYLE &OPTIONAL DONT-OPTIMIZE
		 &AUX OPTIMIZATIONS-BEGUN-FLAG)
  (DECLARE (OPTIMIZE SPEED))
  (DO ((FN)) ((ATOM FORM)) ;Do until no more expansions possible
    (SETQ FN (CAR FORM))
    (UNLESS (OR OPTIMIZATIONS-BEGUN-FLAG
		(> (- (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)
		      (OPT-SAFETY OPTIMIZE-SWITCH))
		   1 ))
      ;; Check for too few or too many arguments
      (CHECK-NUMBER-OF-ARGS FORM FN))
    ;; If function is redefined locally with FLET,
    ;; don't use things that reflect its global definition.
    (WHEN (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)
      (RETURN))
    (UNLESS OPTIMIZATIONS-BEGUN-FLAG
      ;; Do style checking
      (AND CHECK-STYLE (NULL INHIBIT-STYLE-WARNINGS-SWITCH)
	   (COND ((ATOM FN)
		  (WHEN (SYMBOLP FN)
		    (LET (( TM (GET FN 'STYLE-CHECKER) ))
		      (COND (TM
			     (WHEN
			       ;; The following test attempts to distinguish original code
			       ;; which we want to style check from macro expansions which
			       ;; we don't want to check.
			       (OR (NEQ (SI:%AREA-NUMBER FORM) QCOMPILE-TEMPORARY-AREA)
				   (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA)
				   #+compiler:debug
				   (NOT *DEFAULT-DEFS-FROM-HOST*)	; merciless option
				   (EQ *PACKAGE* KERNEL-PACKAGE)
				   )
			       (IF (ATOM TM)
				   (FUNCALL TM FORM)
				 (DOLIST ( HANDLER TM )
				   (FUNCALL HANDLER FORM) ))))
			    (CHECK-CONFORMANCE
			     (CHECK-FORM-FOR-NON-STANDARD-FUNCTION FORM))
			    #+compiler:debug
			    ((AND COMPILING-COMMON-LISP
				  (EQ (SYMBOL-PACKAGE FN) ZETALISP-PACKAGE)
				  OBSOLETE-FUNCTION-WARNING-SWITCH
				  *WARN-OF-SUPERSEDED-FUNCTIONS-P*)
			     (WARN 'ZETALISP-PACKAGE :OBSOLETE
				   "~S is a Zetalisp function which is considered obsolete in Common Lisp."
				   FN)) ))))
		 ((NOT RUN-IN-MACLISP-SWITCH))
		 ((MEMBER (CAR FN) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA) :TEST #'EQ)
		  ;; Note: CLI:LAMBDA and CLI:NAMED-LAMBDA deliberately
		  ;;  omitted since this is only for MacLisp.
		  (LAMBDA-STYLE FN))
	      )))
    ;; Apply optimizations
    (OR (AND (SYMBOLP FN)
	     (NOT DONT-OPTIMIZE)
	     (LET (( TM (GET FN 'OPTIMIZERS) ))
	       (COND ((NULL TM) NIL)
		     ((CONSP TM)
		      (DOLIST (OPT TM)
			(UNLESS (EQ FORM (SETQ FORM (FUNCALL OPT FORM)))
			  ;; Optimizer changed something, don't do macros this pass
			  (RETURN (SETQ OPTIMIZATIONS-BEGUN-FLAG T)))))
		     (T (UNLESS (EQ FORM (SETQ FORM (FUNCALL TM FORM)))
			  ;; Optimizer changed something, don't do macros this pass
			  (SETQ OPTIMIZATIONS-BEGUN-FLAG T))))))
	(AND DONT-OPTIMIZE
	     ;; Expand macros but not DEFSUBSTs
	     (NOT (EQ (CAR-SAFE (DECLARED-DEFINITION (CAR FORM))) 'MACRO))
	     (RETURN) )
	;; No optimizer did anything => try expanding macros.
	(WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S:" FN)
	  ;; This LET returns T if we expand something.
	  (LET ((OLD-FORM FORM)
		(DEFAULT-CONS-AREA MACRO-CONS-AREA)
		(RECORD-MACROS-EXPANDED T)
		(*EVALHOOK* #'EVAL-FOR-TARGET))
	    (SETQ FORM (MACROEXPAND-1 FORM *LOCAL-ENVIRONMENT*))
	    (IF (AND (EQ FORM OLD-FORM)
		     (EQ (CAR FORM) (CAR OLD-FORM)))
		;; Stop looping, no expansions apply
		(RETURN)
	      T)))
	;; The body of the WARN-ON-ERRORS either does RETURN or returns T.
	;; So if we get here, there was an error inside it.
	(RETURN (SETQ FORM `(ERROR-MACRO-EXPANDING ',FORM))))
    ;; Only do style checking the first time around
    (SETQ CHECK-STYLE NIL)
    ;; If macro expansion has been done, optimize the expansion.
    (SETQ DONT-OPTIMIZE NIL) )
  ;; Result is FORM
  FORM)
 

(DEFUN compiler:CHECK-COLD ( FNAME )
  ;; If the file being compiled has the :COLD-LOAD attribute,
  ;; issue a warning message if the function with name FNAME
  ;; is defined in a file which does not have the :COLD-LOAD attribute.
  ;; This provides protection against trying to call something
  ;; which won't be loaded yet.
  ;; 1/23/85 - Original version.
  ;; 2/19/85 - Temporarily suppress error in QC-FILE unless extra SAFETY.
  ;; 1/31/86 - Check :COMPILATION-DEFINED pathname also.
  ;; 3/14/86 - Use GET-FOR-TARGET instead of GET.
  ;; 6/30/86 - Fix to not error when the pathname property is a string instead of a pathname instance.
  ;;11/24/86 - Suppress warning when INHIBIT-STYLE-WARNINGS-SWITCH is true.
  ;; 2/22/89 DNG - Don't warn on %POP or TV:WHO-LINE-RUN-STATE-UPDATE .
  ;;10/30/89 DNG - Don't warn about EVAL-FOR-TARGET.
  (DECLARE (INLINE GET-FOR-TARGET))
  (WHEN (AND SI:FILE-IN-COLD-LOAD ; current file has COLD-LOAD attribute
	     (SYMBOLP FNAME)
	     ;; Temporarily suppress this check for a QC-FILE with
	     ;; default SAFETY; this is to avoid large numbers of errors
	     ;; during system builds until we are ready to clean them up.
	     (OR (NOT UNDO-DECLARATIONS-FLAG)
		 (> (OPT-SAFETY OPTIMIZE-SWITCH) 1) )
	     #+compiler:debug
	     (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		 (NOT QC-FILE-IN-PROGRESS)
		 (NOT (NULL FASD-STREAM)) )
	     (NULL INHIBIT-STYLE-WARNINGS-SWITCH))
    (LET (( PATHNAME (GET-FOR-TARGET FNAME :SOURCE-FILE-NAME) ))
      (UNLESS (ATOM PATHNAME)
	(SETQ PATHNAME (FIRST (LAST (ASSOC 'DEFUN PATHNAME :TEST #'EQ)))) )
      ;; PATHNAME is where FNAME was defined.
      (UNLESS (OR (NULL PATHNAME) ; undefined functions get another message
		  (MEMBER PATHNAME COLD-LOAD-FILES :TEST #'EQ) 
		  (LET (( COMPILE-PATHNAME (GET-FOR-TARGET FNAME ':COMPILATION-DEFINED) ))
		    (AND (NEQ COMPILE-PATHNAME PATHNAME)
			 (MEMBER COMPILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ)))
		  (NOT (INSTANCEP PATHNAME)))
	;; Not among the files that we already know are in the cold load.
	(LET (( PLIST (AND PATHNAME (SEND PATHNAME :PROPERTY-LIST)) ))
	  (IF (GETF PLIST :COLD-LOAD) ; file has COLD-LOAD attribute
	      ;; File is ok; add it to the list.
	      (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))
		(PUSH PATHNAME COLD-LOAD-FILES) )
	    ;; Check for some special cases of functions that are given
	    ;; temporary default definitions in "SYS:KERNEL;LISP-REINITIALIZE"
	    (UNLESS (MEMBER FNAME '(FERROR CERROR SI:UNENCAPSULATE-FUNCTION-SPEC
				  FS:MAKE-PATHNAME-INTERNAL FS:MAKE-FASLOAD-PATHNAME
				  TV:WHO-LINE-FILE-STATE-SHEET TV:WHO-LINE-RUN-STATE-UPDATE
				  ;; the following are re-defined after the cold load
				  SPECIAL UNSPECIAL PROCLAIM EVAL-FOR-TARGET CONFORMANCE-WARNING
				  ;; a special case, not really a function
				  %POP)
			    :TEST #'EQ)
	      ;; Else, give warning.
	      (WARN ':COLD-LOAD ':PROBABLE-ERROR
		    "Warning: ~S is not available in the cold load."
		    FNAME) )
    ) ) ) ) )
  NIL )

(DEFUN P1SBIND (X KIND PARALLEL IGNORE-NIL-P THIS-FRAME-DECLARATIONS)
  ;;  7/18/85 - Add check for binding of a DEFCONSTANT; previously done in VAR-MAKE-HOME. [SPR 194]
  ;;  9/14/85 - Use EQ instead of STRING-EQUAL to test for IGNORE.
  ;;  1/09/86 - Allow "variable appears twice" message to be suppressed by INHIBIT-STYLE-WARNINGS-SWITCH.
  ;;  3/07/86 - Don't set LOCAL-DECLARATIONS from redundant &SPECIAL flag.
  ;;  4/22/89 - In Scheme mode, permit variables names beginning with ":" or "&".
  ;;  4/26/89 - Return BOUNDVARS as second value.
  ;;  5/03/89 - For MULTIPLE-VALUE-BIND, include NILs in BOUNDVARS.
  ;;  5/08/89 - For parallel binding, don't update PROPAGATE-VAR-SET until after all the bindings are done.
  ;; 11/02/89 - Call CONFORMANCE-WARNING for non-standard lambda list keywords.
  ;;		Add error for macro keywords like &BODY used in a function.
  ;; 12/11/89 clm - Fixed conformance check for non-standard &special forms.  The check for this
  ;;                would correctly catch compiler generated forms, but would get an error on
  ;;                non-conforming code.
  (DECLARE (VALUES VLIST BOUNDVARS))
  (LET (TM EVALCODE VARN (MYVARS NIL) (BOUNDVARS NIL) MISC-TYPES
	SPECIFIED-FLAGS (SPECIALNESS NIL) ALREADY-REST-ARG)
    ;; First look at the var specs and make homes, pushing them on MYVARS (reversed).
    (PROG ()
	  (SETQ EVALCODE 'FEF-QT-DONTCARE)
       A  (COND ((NULL X) (RETURN))
		((SETQ TM (ASSOC (CAR X)
				'((&OPTIONAL . FEF-ARG-OPT)
				  (&REST . FEF-ARG-REST) (&AUX . FEF-ARG-AUX))
				:TEST #'EQ))
		 (COND ((OR (EQ KIND 'FEF-ARG-AUX)
			    (EQ KIND 'FEF-ARG-INTERNAL-AUX))
			(WARN 'BAD-BINDING-LIST ':IMPOSSIBLE
			      "A lambda-list keyword (~S) appears in an internal binding list."
			      (CAR X)))
		       (T (SETQ KIND (CDR TM))))
		 (GO B))
		((SETQ TM (ASSOC (CAR X) '((&EVAL . FEF-QT-EVAL)
					   (&QUOTE . FEF-QT-QT)
					   (&QUOTE-DONTCARE . FEF-QT-DONTCARE))
				 :TEST #'EQ))
		 (SETQ EVALCODE (CDR TM))
		 (GO NON-STANDARD-KEYWORD))
		((SETQ TM (ASSOC (CAR X) '((&FUNCTIONAL . FEF-FUNCTIONAL-ARG)) :TEST #'EQ))
		 (PUSH (CDR TM) MISC-TYPES)
		 (GO NON-STANDARD-KEYWORD))
		((EQ (CAR X) '&SPECIAL)
		 (SETQ SPECIALNESS T)
		 (IF (AND (EQ KIND 'FEF-ARG-INTERNAL-AUX)
			  (CONSP (SECOND X))   ;;clm 12/11/89
			  (EQ (FIRST (SECOND X)) (SECOND (SECOND X))))
		     ;; Binding created by P1-ARG-FIXUP
		     (GO B)
		   (GO NON-STANDARD-KEYWORD)))
		((EQ (CAR X) '&LOCAL)
		 (SETQ SPECIALNESS NIL)
		 (GO NON-STANDARD-KEYWORD))
		((EQ (CAR X) '&EXTENSION) (GO NON-STANDARD-KEYWORD))
		((MEMBER (CAR X) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
		 ;; &KEY and &ALLOW-OTHER-KEYS have been removed by EXPAND-KEYED-LAMBDA, so 
		 ;; the only ones left are those that only apply to DEFMACRO.
		 (WARN 'LAMBDA-LIST-KEYWORDS ':IMPOSSIBLE
		       "Lambda list keyword ~S is not valid in a function." (CAR X))
		 (GO B)))
	  ;; LAMBDA-list keywords have jumped to B.
	  ;; Now (CAR X) should be a variable or (var init).
	  (SETQ VARN (COND ((ATOM (CAR X)) (CAR X)) (T (CAAR X))))
	  (UNLESS (SYMBOLP VARN)
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "~S appears in a list of variables to be bound." VARN)
	    (GO B))
	  (WHEN (AND (KEYWORDP VARN) ; this check added 8/13/84 by D.N.G.
		     (NOT (COMPILING-SCHEME-P)))
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "The keyword ~S appears in a list of variables to be bound.
Keywords are constants and so cannot be used as names of variables." VARN)
	    (GO B))
	  (WHEN (AND (OR (GET-FOR-TARGET VARN 'SYSTEM-CONSTANT)
			 (ASSOC VARN FILE-CONSTANTS-LIST :TEST #'EQ))
		     (NOT (EQ VARN 'NIL)) ; permitted in MULTIPLE-VALUE-BIND
		     (EQ (FIND-TYPE VARN THIS-FRAME-DECLARATIONS)
			 'FEF-SPECIAL) )
	    (WARN 'SYSTEM-CONSTANT-BOUND ':IMPLAUSIBLE
		  "Attempt to bind the constant ~S; the new binding will be local.
If that is what you want, this message can be suppressed by (DECLARE (UNSPECIAL ~S))."
		  VARN VARN)
	    (PUSH `(UNSPECIAL ,VARN) THIS-FRAME-DECLARATIONS) )
	  (WHEN (AND (NOT (OR (EQ VARN 'LISP:IGNORE)
			      (STRING-EQUAL VARN "IGNORED")
			      (NULL VARN)))
		     ;; Does this variable appear again later?
		     ;; An exception is made in that a function argument can be repeated
		     ;; after an &AUX.
		     (DOLIST (X1 (CDR X))
		       (COND ((EQ X1 '&AUX) (RETURN NIL))
			     ((OR (EQ X1 VARN)
				  (AND (NOT (ATOM X1)) (EQ (CAR X1) VARN)))
			      (RETURN T))))
		     (OR PARALLEL
			 (NOT INHIBIT-STYLE-WARNINGS-SWITCH)) )
	    (WARN 'BAD-BINDING-LIST ':IMPLAUSIBLE
		  "The variable ~S appears twice in one binding list."
		  VARN) )
	  (WHEN (AND (CHAR= (CHAR (SYMBOL-NAME VARN) 0) #\&)
		     (NOT (COMPILING-SCHEME-P)))
	    (WARN 'MISSPELLED-KEYWORD ':IMPLAUSIBLE
		  "~S is probably a misspelled keyword." VARN))
	  (WHEN ALREADY-REST-ARG
	    (WARN 'BAD-LAMBDA-LIST ':IMPOSSIBLE
		  "Argument ~S comes after the &REST argument." VARN))
	  (WHEN (EQ KIND 'FEF-ARG-REST)
	    (SETQ ALREADY-REST-ARG T))
	  (COND ((AND IGNORE-NIL-P (NULL VARN))
		 (LET ((P1VALUE NIL))
		   (P1 (CADAR X))) ;Out of order, but works in these simple cases
		 (PUSH NIL BOUNDVARS))
		((OR (NULL VARN) (EQ VARN T))
		 (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARN))
		(T
		 ;; Make the variable's home.
		 (IF SPECIALNESS
		     (LET ((DECL (LIST 'SPECIAL
				       (COND ((SYMBOLP (CAR X)) (CAR X))
					     ((SYMBOLP (CAAR X)) (CAAR X))
					     (T (CADAAR X))))))
		       (UNLESS (SPECIALP (SECOND DECL))
			 ;; If already special anyway, don't put it on LOCAL-DECLARATIONS
			 ;; to avoid warning from FIND-TYPE on a later binding.
			 (PUSH DECL LOCAL-DECLARATIONS) )
		       (PUSH DECL THIS-FRAME-DECLARATIONS)))
		 (LET ((V (P1BINDVAR (CAR X) KIND EVALCODE MISC-TYPES
				     THIS-FRAME-DECLARATIONS)))
		   (PUSH V MYVARS)
		   (PUSH V BOUNDVARS))))
	  (SETQ MISC-TYPES NIL)
       B
	  (SETQ X (CDR X))
	  (GO A)
       NON-STANDARD-KEYWORD
          (CONFORMANCE-WARNING "lambda list keyword ~S" (CAR X))
          (GO B))

    ;; Arguments should go on ALLVARS now, so all args precede all boundvars.
    (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
	(EQ KIND 'FEF-ARG-AUX)
	(SETQ ALLVARS (APPEND SPECIFIED-FLAGS MYVARS ALLVARS)))
    (MAPC #'VAR-COMPUTE-INIT SPECIFIED-FLAGS (CIRCULAR-LIST NIL))

    (PROCESS-BINDING-DECLARATIONS MYVARS THIS-FRAME-DECLARATIONS)

    ;; Now do pass 1 on the initializations for the variables.
    (DO ((ACCUM)
	 (NEW-PROPAGATE 0)
	 (VS (REVERSE MYVARS) (CDR VS)))
	((NULL VS)
	 ;; If parallel binding, put all var homes on VARS
	 ;; after all the inits are thru.
	 (WHEN PARALLEL
	   (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET NEW-PROPAGATE))
	   (UNLESS (ZEROP ALTERED-VAR-SET)
	     ;; Prevent propagation of new variables whose initial
	     ;; values are local variables which were changed as
	     ;; a side effect of a parallel binding.
	     (MAP-VARIABLES-IN-SET
	       #'(LAMBDA (V BIT)
		   (LET ((INIT (VAR-INIT-FORM V)))
		     (WHEN (AND (CONSP INIT)
				(EQ (CAR INIT) 'LOCAL-REF)
				(LOGTEST (CDDR INIT) ALTERED-VAR-SET))
		       (SETQ PROPAGATE-VAR-SET
			     (LOGDIF PROPAGATE-VAR-SET BIT)) )))
	       NEW-PROPAGATE
	       MYVARS) )
	   (SETQ VARS (APPEND MYVARS VARS))
	   (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
		      (EQ KIND 'FEF-ARG-AUX))
		  (MAPC #'VAR-CONSIDER-OVERLAP MYVARS)
		  (SETQ ALLVARS (APPEND MYVARS ALLVARS)))))
	 (VALUES (NREVERSE ACCUM)
		 (NREVERSE BOUNDVARS)))
      (IF PARALLEL
	  (LET ((OLD-PROPAGATE PROPAGATE-VAR-SET))
	    (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)
	    ;; For parallel binding, shouldn't update PROPAGATE-VAR-SET until after 
	    ;; all the bindings are done.
	    (LET ((NEW (LOGDIF PROPAGATE-VAR-SET OLD-PROPAGATE)))
	      (SETQ NEW-PROPAGATE (LOGIOR NEW-PROPAGATE NEW))
	      (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET NEW))))
	;; For sequential binding, put each var on VARS
	;; after its own init.
	(PROGN (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)
	       (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
			  (EQ KIND 'FEF-ARG-AUX))
		      (VAR-CONSIDER-OVERLAP (CAR VS))
		      (PUSH (CAR VS) ALLVARS)))
	       (PUSH (CAR VS) VARS)
	       (LET ((TEM (CDDR (VAR-INIT (CAR VS)))))
		 (AND TEM (PUSH TEM VARS))))))))
 
(DEFUN PROCESS-BINDING-DECLARATIONS ( BOUND-VARS DECL-LIST )
  ;; This function records the information specified by any
  ;;  declarations that are associated with variable bindings,
  ;;  except for SPECIAL which is handled in FIND-TYPE.
  ;;  Declarations currently implemented here are TYPE and IGNORE.
  ;;  Other declarations are handled by PROCESS-PERVASIVE-DECLARATIONS
  ;;  which also issues warnings for unrecognized declarations.
  ;;
  ;;  8/27/86 DNG - Use new function STANDARD-TYPE-NAME-P; make
  ;;		RECORD-VAR-DECLARATIONS a local function; recognize dummy
  ;;		declarations .AUX. and .ARG.; use CANONICALIZE-TYPE-FOR-COMPILER .
  ;; 10/20/86 DNG - Warn about variables declared both SPECIAL and IGNORE.
  ;;  4/25/89 DNG - Add setting of VAR-DATA-TYPE and DECLARED-TYPE .
  ;;  5/03/89 DNG - Support (DECLARE (FUNCTION {var-name}*)).
  ;;		Add support for DEFAULT-TYPE.
  ;; 10/28/89 DNG - Support CL:DYNAMIC-EXTENT. [Recorded, but not yet used.]
  (LET ((DUPLICATED NIL))
    (FLET ((RECORD-VAR-DECLARATIONS ( DECL-KIND DECL-VALUE VAR-NAME-LIST &OPTIONAL NO-WARN)
	     ;; Enters data into the VAR-DECLARATIONS slot of a variable.
	     (DOLIST ( VARNAME VAR-NAME-LIST )
	       (LET (( V (LOOKUP-VAR VARNAME BOUND-VARS) ))
		 (COND
		   ((NULL V)
		    (UNLESS (OR DUPLICATED NO-WARN)
		      (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE
			    "~S declaration given for variable ~S which is not bound at the current level."
			    DECL-KIND VARNAME) ))
		   ((GETF (VAR-DECLARATIONS V) DECL-KIND)
		    (UNLESS NO-WARN
		      (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE
			    "There is more than one ~S declaration for variable ~S."
			    DECL-KIND VARNAME)))
		   ((AND (EQ DECL-KIND 'IGNORE)
			 (EQ (VAR-TYPE V) 'FEF-SPECIAL))
		    (WARN 'IGNORE-SPECIAL ':IMPLAUSIBLE
			  "IGNORE declaration given for special variable ~S." VARNAME))
		   (T
		    (SETF (GETF (VAR-DECLARATIONS V) DECL-KIND) DECL-VALUE)
		    (WHEN (EQ DECL-KIND 'TYPE)
		      (SETF (VAR-DATA-TYPE V) DECL-VALUE)
		      (WHEN (EQ (VAR-TYPE V) 'FEF-SPECIAL)
			(PUSH `(VARIABLE-TYPE ,VARNAME ,DECL-VALUE)
			      LOCAL-DECLARATIONS)) )))))) )
      (DOLIST ( DECL DECL-LIST )
	(WHEN (CONSP DECL)
	  (LET (( DT (FIRST DECL) ))
	    (COND ((NOT (SYMBOLP DT)) NIL) ; avoid error on GETL
		  ((EQ DT 'IGNORE)
		   (RECORD-VAR-DECLARATIONS 'IGNORE 'T (REST DECL)) )
		  ((EQ DT 'TYPE)
		   (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER (SECOND DECL) 'DECLARE)))
		     (UNLESS (EQ CANON 'UNKNOWN) ; unless erroneous
		       (RECORD-VAR-DECLARATIONS 'DECLARED-TYPE (SECOND DECL) (CDDR DECL) T)
		       (RECORD-VAR-DECLARATIONS 'TYPE CANON (CDDR DECL)))))
		  ((STANDARD-TYPE-NAME-P DT)
		   (RECORD-VAR-DECLARATIONS 'TYPE DT (REST DECL)) )
		  ((AND (EQ DT 'FUNCTION)
			(OR (NULL (CDDR DECL))
			    (NOT (LISTP (THIRD DECL)))))
		   ;; Apparently using (DECLARE (FUNCTION x y z)) as an abbreviation for
		   ;; (DECLARE (TYPE FUNCTION x y z)).  This isn't consistent with my 
		   ;; interpretation of CLtL, but it has been adopted by X3J13.
		   (RECORD-VAR-DECLARATIONS 'TYPE DT (REST DECL)) )
		  ((MEMBER DT '(.AUX. .ARG.))
		   ;; Function P1AUX, EXPAND-LAMBDA, or EXPAND-KEYED-LAMBDA has
		   ;; split a lambda-list into args and aux-vars and duplicated
		   ;; the declarations.  Thus we might see declarations
		   ;; that refer to variables not bound here.
		   (SETQ DUPLICATED T))
		  ((EQ DT 'DEFAULT-TYPE)
		   ;; Like TYPE, except just ignore it if the type has already been declared.
		   ;; This is used by TICLOS::PARSE-METHOD
		   (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER (SECOND DECL) 'DECLARE)))
		     (UNLESS (EQ CANON 'UNKNOWN) ; unless erroneous
		       (RECORD-VAR-DECLARATIONS 'TYPE CANON (CDDR DECL) T))))
		  ((EQ DT 'CL:DYNAMIC-EXTENT)
		   (RECORD-VAR-DECLARATIONS 'CL:DYNAMIC-EXTENT 'T (REST DECL)) )
		  (T NIL) )		   ; ignore others here
	    ))))))

 
(DEFUN PROCESS-PERVASIVE-DECLARATIONS (DECLS &OPTIONAL LOCAL-DECLS EXPR-DEBUG-INFO JUNK-ALLOWED-P)
  ;; This function handles any pervasive declarations appearing within a
  ;; function being compiled.  Declarations which affect variable
  ;; binding are processed in P1SBIND and are ignored here.
  ;; Top-level declarations are handled separately by functions
  ;; DECLARE and PROCLAIM.
  ;; 8/13/84 DNG - Removed (PUSHNEW VARNAME FREEVARS) since it will be
  ;;		done by P1 for any special variables which are actually
  ;;		referenced.  This avoids allocating space in the FEF for
  ;;		pointers to the value cells of variables declared
  ;;		SPECIAL but never actually referenced.
  ;; 9/06/84 DNG - Changed function name from PROCESS-SPECIAL-DECLARATIONS.
  ;; 9/11/84 DNG - Add error check for :SELF-FLAVOR declarations.
  ;;12/07/84 DNG - Allow SELF-FLAVOR without colon.
  ;; 1/18/85 DNG - Fix message to say DECLARATION instead of DECLARATIONS;
  ;;		   check SI:INTERPRETER-DECLARATION-TYPE-ALIST.
  ;; 2/20/85 DNG - Suppress :SELF-REF error message in a certain case.
  ;; 3/09/85 DNG - Disallow :SELF-REF declaration within a binding of SELF.
  ;; 1/23/86 DNG - Obsolete warning on keyword declaration names.
  ;; 6/18/86 DNG - Major changes to handling of debug-info declarations.  Push
  ;;		on LOCAL-DECLARATIONS only what is needed there.  Avoid processing
  ;;		top-level declarations twice.
  ;; 6/20/86 DNG - Add JUNK-ALLOWED-P option.
  ;; 7/02/86 DNG - Fix to allow :INTERNAL function to have :SELF-FLAVOR different from parent.
  ;; 7/10/86 DNG - Fix the JUNK-ALLOWED-P option.
  ;; 7/17/86 DNG - Add SYS:DOWNWARD-FUNCTION declaration.
  ;; 8/26/86 DNG - Add handling for FTYPE and FUNCTION declarations [previously ignored].
  ;; 9/02/86 DNG - SI:INTERPRETER-DECLARATION-TYPE-ALIST no longer used in release 3.
  ;;10/01/86 DNG - Add special warning for RETURN-LIST.
  ;;10/11/86 DNG - Permit :EXPR-SXHASH declaration.
  ;;10/17/86 DNG - Warn on non-symbol in SPECIAL declaration.
  ;;11/14/86 DNG - Fix to allow an UNSPECIAL declaration to shadow a previous SPECIAL declaration.
  ;; 5/23/88 DNG - Add support for TICLOS::SPECIALIZERS declarations.
  ;; 4/06/89 DNG - Recognize ARGLIST declaration in any package and accept the 
  ;;		Lucid syntax as well as the LispM syntax.
  ;; 4/25/89 DNG - Minor fixes for SELF-FLAVOR and DOWNWARD-FUNCTION criteria.
  ;; 4/28/89 DNG - Permit DEFAULT-TYPE.
  ;;10/28/89 DNG - Permit CL:DYNAMIC-EXTENT.
  ;;11/02/89 DNG - Conformance warning for SELF-FLAVOR, UNSPECIAL, and DEF declarations.
  (DECLARE (ARGLIST THIS-FRAME-DECLARATIONS &OPTIONAL OLD-LOCAL-DECLARATIONS OLD-EXPR-DEBUG-INFO)
	   (VALUES NEW-LOCAL-DECLARATIONS NEW-EXPR-DEBUG-INFO))
  (DOLIST (DECL DECLS)
    (IF (OR (ATOM DECL) (NOT (SYMBOLP (FIRST DECL))))
	(WARN 'PROCESS-PERVASIVE-DECLARATIONS ':IMPOSSIBLE
	      "Invalid declaration syntax: (DECLARE ~S)" DECL)
      (LET (( DT (FIRST DECL) ) DSTRING )
	(DECLARE (SYMBOL DT))
	(BLOCK WARNING
	  (COND
	    ( (MEMBER DT '( TYPE IGNORE .ARG. SI:DOWNWARD-FUNARG DEFAULT-TYPE CL:DYNAMIC-EXTENT)
		      :TEST #'EQ)
	     ;; Ignore these here.  They are handled by function
	     ;;   PROCESS-BINDING-DECLARATIONS which is called by P1SBIND.
	     ;; [SYS:DOWNWARD-FUNARG is for brand S compatibility.]
	     )
	    ( (MEMBER DT '(INLINE NOTINLINE TRY-INLINE) :TEST #'EQ)
	     (DOLIST ( FN (REST DECL))
	       (IF (SI:VALIDATE-FUNCTION-SPEC FN)
		   (PUSH (CONS (IF (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)
				   (LIST ':INTERNAL
					 (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)
					 FN)
				 FN)
			       DT)
			 INLINE-DECLARATIONS)
		 (WARN 'SI:VALIDATE-FUNCTION-SPEC ':IGNORABLE-MISTAKE
		       "Invalid function spec ~S in ~S declaration."
		       FN DT) )))

	    ( (EQ DT 'OPTIMIZE)
	     (DECLARE-OPTIMIZE (REST DECL)) )

	    ( (EQ DT '.AUX.)
	     ;; duplicate declarations created by P1AUX for P1SBIND; ignore here.
	     (RETURN) )

	    ( (MEMBER DT '( FTYPE FUNCTION ) :TEST #'EQ)
	     (SETQ LOCAL-DECLS (DECLARE-FTYPE DECL LOCAL-FUNCTIONS LOCAL-DECLS)) )

	    ((MEMBER DT *LOCAL-DECLARATIONS-SPECIFIERS* :TEST #'EQ)
	     (COND ((MEMBER DT '(SPECIAL :SPECIAL) :TEST #'EQ) 
		    (DOLIST (VARNAME (CDR DECL))
		      (IF (SYMBOLP VARNAME)
			  (PUSH (MAKE-FREE-VAR-HOME VARNAME) VARS)
			(WARN 'SPECIAL :IMPOSSIBLE
			      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL)
			)))
		   ((MEMBER DT '(UNSPECIAL :UNSPECIAL) :TEST #'EQ)
		    (DOLIST (VARNAME (CDR DECL))
		      (IF (SYMBOLP VARNAME)
			  (LET ((SPECIAL NIL))
			    (DOLIST (V VARS)
			      (WHEN (EQ VARNAME (VAR-NAME V))
				(COND ((EQ (VAR-TYPE V) 'FEF-SPECIAL)
				       (SETQ SPECIAL V))
				      (SPECIAL
				       (PUSH V VARS)
				       (RETURN))
				      (T (RETURN))))))
			(WARN 'SPECIAL :IMPOSSIBLE
			      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL)
			))
		    (WHEN (IN-SOURCE-AREA-P DECL)
		      (CONFORMANCE-WARNING "~A declaration" DT)))
		   ((EQ DT 'DEF)
		    (WHEN (IN-SOURCE-AREA-P DECL)
		      (CONFORMANCE-WARNING "~A declaration" DT)))
		   )
	     ;; Push these on LOCAL-DECLARATIONS for future reference.
	     ;;   SPECIAL and UNSPECIAL are noticed in FIND-TYPE;
	     ;;	  DEF is used by SYS:DECLARED-DEFINITION in file MINDEFS.
	     (PUSH DECL LOCAL-DECLS) )

	    ((STRING-EQUAL (SETQ DSTRING (STRING DT)) "SELF-FLAVOR")
	     (COND ((AND (OR (NULL SELF-FLAVOR-DECLARATION) ; not already declared
			     ;; The following test is to permit an :INTERNAL function to
			     ;; have a different flavor from its parent.
			     (AND (ZEROP EXPRESSION-SIZE) (NULL ALLVARS)
				  (EQ SELF-FLAVOR-DECLARATION (COMPILAND-FLAVOR *CURRENT-COMPILAND*))))
			 (NOT (LOOKUP-VAR 'SELF ALLVARS)))
		    ;; We can make this function into a method for the indicated
		    ;; flavor providing that SELF has been set up before the
		    ;; function is entered so that the microcode can get the
		    ;; right mapping table at function entry.
		    (SETF SELF-FLAVOR-DECLARATION (REST DECL))
		    (WHEN (AND (IN-SOURCE-AREA-P DECL)
			       (NOT (MEMBER CHECK-CONFORMANCE '(:LUCID :ALLEGRO)))
			       (NEQ (CAR-SAFE (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) ':METHOD))
		      (CONFORMANCE-WARNING "(DECLARE ~S)" DECL))
		    (WHEN (AND SELF-FLAVOR-DECLARATION
			       ;; If the user just did (declare (:self-flavor flname)),
			       ;; compute the full declaration for that flavor.
			       (NULL (CDR SELF-FLAVOR-DECLARATION)))
		      (SETF SELF-FLAVOR-DECLARATION
			    (CDR (SI:FLAVOR-DECLARATION (CAR SELF-FLAVOR-DECLARATION)))) ))
		   ((INCLUDED-FLAVOR-P (SECOND DECL) (CAR SELF-FLAVOR-DECLARATION))
		    ;; Redundant declaration, ignore.
		    )
		   (T (WARN ':SELF-FLAVOR ':IMPOSSIBLE
			    "In a method for flavor ~S, there is a :SELF-FLAVOR declaration for
flavor ~S, which is not included in ~S."
			    (CAR SELF-FLAVOR-DECLARATION) (SECOND DECL)
			    (CAR SELF-FLAVOR-DECLARATION) ) ) )
	     (RETURN-FROM WARNING) )

	    ( (EQ DT 'SI:DOWNWARD-FUNCTION) ; for brand S compatibility
	     (WHEN (AND (ZEROP EXPRESSION-SIZE) ; at beginning of function
			(>= (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)))
	       (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'SI:DOWNWARD-FUNCTION)
		     T))) ; used by BREAKOFF

	    ( (ASSOC DT SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES* :TEST #'EQ)
	     ;; These declarations have no effect other than to be copied into
	     ;; the function's debugging info.  They are significant only at the
	     ;; top level of the function.
	     (PUSH DECL EXPR-DEBUG-INFO) )

	    ( (EQ DT ':EXPR-SXHASH)
	     (PUSH (IF (COMPILING-FOR-V2) (CONS DT (SECOND DECL)) DECL)
		   EXPR-DEBUG-INFO)
	     (RETURN-FROM WARNING) )

	    ( (STANDARD-TYPE-NAME-P DT T)
	     ;; The name of a standard type; ignore here since this is
	     ;;	  handled in PROCESS-BINDING-DECLARATIONS .
	     )

	    ( (EQ DT 'TICLOS::SPECIALIZERS)
	     (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) DT) (REST DECL)))

	    ((STRING-EQUAL DSTRING "ARGLIST") ; permit in any package
	     (PUSH (CONS 'ARGLIST (IF (AND (NULL (CDDR DECL))
					   (LISTP (SECOND DECL))) ; looks like Lucid style
				      (SECOND DECL)
				    (CDR DECL) ; else assume LispM style
				    ))
		   EXPR-DEBUG-INFO))

	    ( (MEMBER DT DECLARATIONS-IGNORED :TEST #'EQ)
	     (RETURN-FROM WARNING) )

	    ( (MEMBER DT '(SI:ARRAY-REGISTER SI:ARRAY-REGISTER-1D) 
		      :TEST #'EQ)
	     ;; ignored for brand S compatibility
	     (RETURN-FROM WARNING) )

	    ((STRING-EQUAL DSTRING "RETURN-LIST") ; now in ZLC package
	     (WARN 'RETURN-LIST ':IGNORABLE-MISTAKE
		   "(DECLARE ~S) doesn't work anymore, use (DECLARE (VALUES ...))"
		   DECL)
	     (RETURN-FROM WARNING))
	    
	    ( JUNK-ALLOWED-P
	     ;; At top level, LOCAL-DECLARATIONS may contain things other than
	     ;; valid declaration specifiers.  Just pass them through in same order.
	     (SETQ LOCAL-DECLS (NCONC LOCAL-DECLS (CONS DECL NIL))) )

	    ( T (WARN 'PROCESS-PERVASIVE-DECLARATIONS ':PROBABLE-ERROR
		      "Unrecognized declaration: (DECLARE ~S)
If you want it allowed and ignored, do (PROCLAIM '(DECLARATION ~S))" DECL DT)
		(RETURN-FROM WARNING) )
	    )				   ; end of COND
	  (WHEN (AND COMPILING-COMMON-LISP
		     (NOT INHIBIT-STYLE-WARNINGS-SWITCH)
		     (KEYWORDP DT))
	    (WARN ':DECLARE ':OBSOLETE
		  "(DECLARE (~S ...)) is obsolete; use (DECLARE (~A ...))."
		  DT DT) )
	  ) ; end of BLOCK WARNING
	))) ; end of DOLIST
  (VALUES LOCAL-DECLS EXPR-DEBUG-INFO) )


(defun cl:VARIABLE-INFORMATION (variable &optional environment)
  (declare (values kind localp declaration-alist))
  (let ((var (and (same-environment-p environment *local-environment*)
		  (boundp 'vars)
		  (lookup-var variable))))
    (if (null var)
	(cond ((constantp variable) (values ':constant nil nil))
	      ((specialp variable t)
	       (values ':special
		       (let ((type (get variable 'declared-type t)))
			 (and (neq type t)
			      `((type . ,type))))
		       nil))
	      (t (values nil nil nil)))
      (values (if (eq (var-type var) 'FEF-SPECIAL) ':special ':lexical)
	      (not (eq (var-kind var) 'FEF-ARG-FREE))
	      (loop for (key value) on (var-declarations var) by #'cddr
		    collect (cons key value))))))

 

(defun cl:FUNCTION-INFORMATION (function-spec &optional environment)
  (declare (values kind localp declaration-alist))
  (let ((def (declared-definition function-spec environment)))
    (if (null def)
	(values nil nil nil)
      (values (cond ((eq (car-safe def) 'macro) ':macro)
		    ((functionp def nil) ':function)
		    ((macro-function function-spec) ':macro)
		    (t ':special-form))
	      (and environment (neq def (fdefinition-safe function-spec 'macro)))
	      (let ((inline (or (inline-decl function-spec)
				(and (or (sys:compiled-subst? def)
					 (member (car-safe def) sys:*subst-lambdas* :test #'eq))
				     'inline)))
		    (ftype (getdecl function-spec 'function-result-type 't environment)))
		(and (or inline (neq ftype t))
		     `((inline . ,inline)
		       (ftype . ,ftype))))
	      ))))
 

(defun cl:DECLARATION-INFORMATION (decl-name &optional environment)
  "This function returns information about declarations named by the
symbol DECL-NAME that are in force in the environment ENVIRONMENT.
The currently supported values for DECL-NAME are OPTIMIZE and DECLARATION."
  ;;  7/12/89 DNG - Original.
  (ecase decl-name
    (OPTIMIZE (let-if (and qc-file-in-progress
			   (null environment))
		      ((optimize-switch (symeval-globally 'optimize-switch)))
		(cdr (optimize-status))))
    (DECLARATION declarations-ignored)
    ))

(defun cl:ENCLOSE (lambda-expression &optional environment)
  "This function returns an object of type FUNCTION that is equivalent to what
would be obtained by evaluating `(FUNCTION ,LAMBDA-EXPRESSION) in syntactic 
environment ENVIRONMENT."
  ;;  7/12/89 DNG - Original.
  (function-for-target lambda-expression environment))

))




#!C
; From file p1hand.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; p1hand.É#É"



(DEFUN COMPILER::P1-RETURN-HANDLER (COMPILER::FUNCT COMPILER::BLOCK-NAME COMPILER::VALUE-LIST)
  (LET (COMPILER::PROGDESC
	ARG)
    (SETQ COMPILER::PROGDESC
	  (COND
	    ((AND (NULL COMPILER::BLOCK-NAME) COMPILER::RETPROGDESC))
	    ((ASSOC COMPILER::BLOCK-NAME COMPILER::PROGDESCS :TEST #'EQ))
	    ((EQ COMPILER::FUNCT 'RETURN)
	     (COMPILER:WARN 'COMPILER::BAD-PROG ':IMPOSSIBLE
			    "~S is not within a BLOCK named NIL or a PROG, DO, or LOOP."
			    (CONS COMPILER::FUNCT COMPILER::VALUE-LIST))
	     NIL)
	    (T
	     (COMPILER:WARN 'COMPILER::BAD-PROG ':IMPOSSIBLE
			    "There is a RETURN-FROM ~S not inside a BLOCK or PROG of that name."
			    COMPILER::BLOCK-NAME)
	     NIL)))
    (SETQ ARG
	  (COND
	    ((= (LENGTH COMPILER::VALUE-LIST) 1)
	     (LET ((COMPILER::P1VALUE
		    (IF COMPILER::PROGDESC
		      (COMPILER::PROGDESC-IDEST COMPILER::PROGDESC)
		      T)))
	       (COMPILER::P1 (FIRST COMPILER::VALUE-LIST))))
	    ((AND (NULL COMPILER::VALUE-LIST) COMPILER::COMPILING-COMMON-LISP) '(QUOTE NIL))
	    (T
	     (COMPILER:CONFORMANCE-WARNING "~S should be ~S"
					   `(RETURN-FROM ,COMPILER::BLOCK-NAME
					       ,@COMPILER::VALUE-LIST)
					   `(RETURN-FROM ,COMPILER::BLOCK-NAME
					       (VALUES . ,COMPILER::VALUE-LIST)))
	     (COMPILER::P1EVARGS (CONS 'VALUES COMPILER::VALUE-LIST)))))
    (COND
      ((AND (CONSP ARG) (MEMBER (FIRST ARG) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)) ARG)
      ((OR (NULL COMPILER::PROGDESC) (ZEROP COMPILER::1-IF-LIVE-CODE))
       `(RETURN-FROM ,COMPILER::PROGDESC ,ARG ,COMPILER::VARS))
      (T
       (SETF COMPILER::ALTERED-VAR-SET
	     (LOGIOR COMPILER::ALTERED-VAR-SET (COMPILER::PROGDESC-USED-BIT COMPILER::PROGDESC)))
       (COND
	 ((NEQ (COMPILER::PROGDESC-COMPILAND COMPILER::PROGDESC) COMPILER::*CURRENT-COMPILAND*)
	  (PUSHNEW COMPILER::*CURRENT-COMPILAND*
	     (COMPILER::PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG COMPILER::PROGDESC) :TEST #'EQ)
	  `(*THROW ,(COMPILER::P1V (COMPILER::PROGDESC-CATCH-TAG COMPILER::PROGDESC)) ,ARG))
	 (T
	  (LET ((COMPILER::TAG
		 (COMPILER::GOTAGS-SEARCH (COMPILER::PROGDESC-RETTAG COMPILER::PROGDESC) T
					  COMPILER::GOTAGS)))
	    (INCF (COMPILER::GOTAG-USE-COUNT COMPILER::TAG)))
	  `(RETURN-FROM ,COMPILER::PROGDESC ,ARG ,COMPILER::VARS))))))) 


(DEFUN COMPILER::P1PROGN-1 (COMPILER::FORMS)
  (OR
   (LET* ((COMPILER::DEST COMPILER::P1VALUE)
	  (COMPILER::P1VALUE NIL)
	  (COMPILER::FORMS-LEFT COMPILER::FORMS)
	  COMPILER::BEFORE
	  COMPILER::AFTER
	  (COMPILER::BODY
	   (LOOP COMPILER::UNTIL (NULL COMPILER::FORMS-LEFT) DO
	      (PROGN
		(SETQ COMPILER::BEFORE (CAR COMPILER::FORMS-LEFT))
		(SETQ COMPILER::FORMS-LEFT (CDR COMPILER::FORMS-LEFT))
		(WHEN (NULL COMPILER::FORMS-LEFT)
		  (SETQ COMPILER::P1VALUE COMPILER::DEST))
		(SETQ COMPILER::AFTER (COMPILER::P1 COMPILER::BEFORE)))
	      WHEN (OR COMPILER::P1VALUE (NOT (COMPILER::NO-SIDE-EFFECTS-P COMPILER::AFTER)))
	      COMPILER::COLLECTING COMPILER::AFTER COMPILER::ELSE DO
	      (COMPILER::DISCARD COMPILER::AFTER) COMPILER::UNTIL
	      (AND (CONSP COMPILER::AFTER)
		 (MEMBER (FIRST COMPILER::AFTER) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)
		 (PROG1
		   T
		   (COMPILER::P1-DEAD-FORMS COMPILER::FORMS-LEFT))))))
     (WHEN (EQ (CAR-SAFE (FIRST COMPILER::BODY)) 'PROGN)
       (SETQ COMPILER::BODY (NCONC (REST (FIRST COMPILER::BODY)) (REST COMPILER::BODY))))
     COMPILER::BODY)
   '((QUOTE NIL)))) 


(DEFUN COMPILER::P1THE (COMPILER::FORM)
  (COMPILER::CHECK-ARG-COUNT COMPILER::FORM 2 2)
  (LET ((TYPE
	 (COMPILER::CANONICALIZE-TYPE-FOR-COMPILER (SECOND COMPILER::FORM) COMPILER::FORM T))
	(EXP (THIRD COMPILER::FORM)))
    (IF (OR (EQ TYPE 'COMPILER::UNKNOWN) (EQ TYPE 'T))
      (COMPILER::P1 EXP)
      (COMPILER::P1-WITH-ANNOTATION
       (IF (COMPILER::VALIDATE-TYPES-P)
	 (LET ((COMPILER::EXP2 (IF (EQ (CAR-SAFE EXP) 'PROGN)
				 (COMPILER::PROGN-OPT EXP)
				 EXP)))
	   `(COMPILER::LET-FOR-LAMBDA ((COMPILER::.VALUE. ,EXP))
	     (DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
	     (IF (TYPEP COMPILER::.VALUE. ',(SECOND COMPILER::FORM))
	       COMPILER::.VALUE.
	       (COMPILER::THE-TYPE-ERROR COMPILER::.VALUE.
					 ',(IF (OR (ATOM COMPILER::EXP2)
					       (< (LENGTH COMPILER::EXP2) 3))
					     COMPILER::EXP2
					     (LET ((*PRINT-LENGTH* 3)
						   (*PRINT-LEVEL* 2))
					       (PRINC-TO-STRING COMPILER::EXP2)))
					 ',(SECOND COMPILER::FORM)))))
	 EXP)
       #'COMPILER::P1 TYPE)))) 



))


;; may 07/09/90 Added below since COMPILER::BIND-OPT references it. 
#!C
; From file P2HAND.LISP#46 COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.É#É"


(DEFUN (:PROPERTY BIND-SPECIAL P2) (ARGL DEST)
  ;; 10/9/89 DNG - Original.  (BIND-SPECIAL varname value) is generated by optimizer for BIND.
  (DESTRUCTURING-BIND (VARNAME VALUE) ARGL
    (OUTI (LIST (COND ((EQUAL VALUE '(QUOTE NIL)) 'BIND-NIL)
		      ((EQ VALUE VARNAME) 'BIND-CURRENT)
		      ((EQUAL VALUE '(QUOTE T)) 'BIND-T)
		      (T (P2PUSH VALUE) 'BIND-POP))
		0 `(SPECIAL ,VARNAME)))
    (UNLESS (EQ DEST 'D-IGNORE)
      (P2 VALUE DEST))
    (VALUES)))
))


#!C
; From file p1opt.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; p1opt.É#É"


(DEFUN COMPILER::QUOTES-ANY-ARGS (COMPILER::FNAME)
  (LET ((COMPILER::HANDLER (GET COMPILER::FNAME 'COMPILER::P2)))
    (IF COMPILER::HANDLER
      (AND
       (NOT
	(MEMBER COMPILER::HANDLER '(COMPILER::P2-AR-1 COMPILER::P2-SET-AR-1 COMPILER::P2DEST)
		:TEST #'EQ))
       (NOT
	(MEMBER COMPILER::FNAME
		'(PROGN
		   PROG1
		   PROG2
		   FUNCALL
		   LEXPR-FUNCALL
		   APPLY
		   ATOM
		   NOT
		   SYS:%PUSH
		   SYS:%POP
		   COMPILER::%DUP
		   SYS:%CALL
		   COMPILER::%PUSH-VALUES-AND-COUNT
		   LDB
		   SYS:%MAKE-EXPLICIT-STACK-LIST
		   SYS:%MAKE-EXPLICIT-STACK-LIST*
		   FLOOR
		   CEILING
		   TRUNCATE
		   ROUND
		   REM
		   VALUES
		   VALUES-LIST
		   SYS:%ASSURE-PDL-ROOM
		   MULTIPLE-VALUE-CALL
		   MULTIPLE-VALUE-PROG1
		   MULTIPLE-VALUE-LIST
		   DONT-OPTIMIZE
		   NTH-VALUE
		   SYS:FUNCALL-WITH-MAPPING-TABLE-INTERNAL
		   SYS:LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL
		   *THROW
		   THROW)
		:TEST #'EQ)))
      (MEMBER COMPILER::FNAME
	      '(QUOTE COMPILER::LOCAL-REF SYS:SELF-REF COMPILER::LEXICAL-REF
		COMPILER::BREAKOFF-FUNCTION)
	      :TEST #'EQ)))) 




(COMPILER:ADD-OPTIMIZER SYS:COMMON-LISP-AREF COMPILER::COMMON-LISP-AREF-EXPANDER
   SYS:COMMON-LISP-AR-1 SYS:COMMON-LISP-AR-2 SYS:COMMON-LISP-AR-3) 

(COMPILER:ADD-OPTIMIZER ASET COMPILER::ASET-EXPANDER AS-1 AS-2 AS-3)

(COMPILER:ADD-OPTIMIZER SYS:SET-AREF COMPILER::SET-AREF-EXPANDER SYS:SET-AR-1 SYS:SET-AR-2
   SYS:SET-AR-3)

(COMPILER:ADD-OPTIMIZER ALOC COMPILER::ALOC-EXPANDER AP-1 AP-2 AP-3)


(COMPILER::ADD-POST-OPTIMIZER BIND COMPILER::BIND-OPT) 


(DEFUN COMPILER::BIND-OPT (COMPILER::FORM)
  (LET ((COMPILER::LOC (SECOND COMPILER::FORM)))
    (IF (AND (CONSP COMPILER::LOC) (EQ (FIRST COMPILER::LOC) 'SYS:%EXTERNAL-VALUE-CELL)
	(COMPILER::QUOTEP (SECOND COMPILER::LOC))
	(OR (NULL COMPILER::P1VALUE) (COMPILER::NO-SIDE-EFFECTS-P (THIRD COMPILER::FORM))))
      (LET ((COMPILER::VARNAME (SECOND (SECOND COMPILER::LOC))))
	(COMPILER::MAKESPECIAL COMPILER::VARNAME)
	`(COMPILER::BIND-SPECIAL ,COMPILER::VARNAME ,(THIRD COMPILER::FORM)))
      COMPILER::FORM))) 


(DEFUN COMPILER::SETF-OPT (COMPILER::FORM)
  (IF (AND (CONSP (SECOND COMPILER::FORM)) (EQ (FIRST (SECOND COMPILER::FORM)) 'VALUES)
      (NOT (EQ COMPILER::P1VALUE 'COMPILER::TOP-LEVEL-FORM)))
    (LET ((COMPILER::RESULT NIL))
      (COMPILER:CONFORMANCE-WARNING "use ~S instead of ~S" 'MULTIPLE-VALUE-SETQ COMPILER::FORM)
      (UNLESS (NULL (CDDDR COMPILER::FORM))
	(PUSH `(SETF . ,(CDDDR COMPILER::FORM)) COMPILER::RESULT))
      (LET ((COMPILER::TEMP (GENSYM)))
	(DOLIST (COMPILER::PLACE (REST (SECOND COMPILER::FORM)))
	  (SETQ COMPILER::PLACE (COMPILER::PRE-OPTIMIZE COMPILER::PLACE T))
	  (PUSH
	   (COND
	     ((ATOM COMPILER::PLACE)
	      (IF (NULL COMPILER::PLACE)
		'(COMPILER::%POP-PDL)
		`(SETQ ,COMPILER::PLACE (SYS:%POP))))
	     ((MEMBER (GET (CAR COMPILER::PLACE) 'SYS::SETF-METHOD) '(SYS:SET-AREF SYS:SET-AR-1))
	      `(ASET (SYS:%POP) ,@(REST COMPILER::PLACE)))
	     (T `(LET ((,COMPILER::TEMP (SYS:%POP)))
		   (SETF ,COMPILER::PLACE ,COMPILER::TEMP))))
	   COMPILER::RESULT)))
      `(PROGN
	 (COMPILER::MULTIPLE-VALUE-PUSH ,(LENGTH (REST (SECOND COMPILER::FORM)))
	  ,(THIRD COMPILER::FORM))
	 ,@COMPILER::RESULT))
    COMPILER::FORM)) 


(UNLESS (EQ (FIND-SYMBOL "GET" "CL") (FIND-SYMBOL "GET" "GLOBAL"))
  (COMPILER::ADD-POST-OPTIMIZER COMMON-LISP:GET COMPILER::CL-GET-OPT COMPILER::INTERNAL-GET-2
     SYS:INTERNAL-GET-3)
  (DEFUN COMPILER::CL-GET-OPT (COMPILER::FORM)
    (IF (OR
      (>= (COMPILER::OPT-SPEED COMPILER::OPTIMIZE-SWITCH)
	  (COMPILER::OPT-SAFETY COMPILER::OPTIMIZE-SWITCH))
      (COMPILER::EXPR-TYPE-P (SECOND COMPILER::FORM) 'SYMBOL))
      `(GET . ,(REST COMPILER::FORM))
      COMPILER::FORM))
  (COMPILER::ADD-POST-OPTIMIZER SYS::SETF-GET COMPILER::SETF-GET-OPT SYS::SETPROP)
  (DEFUN COMPILER::SETF-GET-OPT (COMPILER::FORM)
    (IF (OR
      (>= (COMPILER::OPT-SPEED COMPILER::OPTIMIZE-SWITCH)
	  (COMPILER::OPT-SAFETY COMPILER::OPTIMIZE-SWITCH))
      (COMPILER::EXPR-TYPE-P (SECOND COMPILER::FORM) 'SYMBOL))
      `(SYS::SETPROP . ,(REST COMPILER::FORM))
      COMPILER::FORM))) 

))



#!C
; From file p1style.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; p1style.É#É"



(DEFUN COMPILER::FORMAT-STYLE (COMPILER::FORM)
  (COMPILER::NEED-TWO-ARGS COMPILER::FORM)
  (IF (STRINGP (SECOND COMPILER::FORM))
    (COMPILER:WARN 'COMPILER::BAD-ARGUMENT :IMPLAUSIBLE
		   "FORMAT is used with ~S as its first argument,
 which should be a stream, T or NIL."
		   (CADR COMPILER::FORM))
    (WHEN COMPILER:CHECK-CONFORMANCE
      (COMPILER::CHECK-FORMAT-STRING (THIRD COMPILER::FORM) COMPILER::FORM)))) 


(DEFUN COMPILER::IMBEDDED-DEFUN (COMPILER::FORM)
  (UNLESS (COMPILER::TOP-LEVEL-DUMMY-FUNCTION-P COMPILER::*CURRENT-COMPILAND*)
    (COMPILER:WARN 'DEFUN :IMPLAUSIBLE
		   "(~A ~A ...) is imbedded within another function; either there is
a right parenthesis missing or you should be using ~A instead."
		   (FIRST COMPILER::FORM) (SECOND COMPILER::FORM)
		   (IF (EQ (FIRST COMPILER::FORM) 'DEFUN)
		     'FLET
		     'MACROLET)))
  (WHEN (AND COMPILER:CHECK-CONFORMANCE (CONSP (SECOND COMPILER::FORM))
      (NEQ (CAR (SECOND COMPILER::FORM)) 'SETF)
      (SYS:VALIDATE-FUNCTION-SPEC (SECOND COMPILER::FORM)))
    (COMPILER:CONFORMANCE-WARNING "function spec ~S" (SECOND COMPILER::FORM)))) 


(DEFUN COMPILER::IN-SOURCE-TREE-P (COMPILER::ITEM COMPILER::TREE)
  (DECLARE (OPTIMIZE SPEED (SAFETY 0) (COMPILATION-SPEED 0)))
  (IF (ATOM COMPILER::TREE)
    (EQ COMPILER::ITEM COMPILER::TREE)
    (AND (NOT (EQ (SYS:%AREA-NUMBER COMPILER::TREE) MACRO-COMPILED-PROGRAM))
       (CASE (FIRST COMPILER::TREE)
	 (QUOTE NIL)
	 (COMPILER::IN-SOURCE-TREE-P COMPILER::ITEM (SECOND COMPILER::TREE))
	 (OTHERWISE
	  (DOLIST (COMPILER::ELEMENT COMPILER::TREE NIL)
	    (WHEN (IF (ATOM COMPILER::ELEMENT)
	       (EQ COMPILER::ITEM COMPILER::ELEMENT)
	       (COMPILER::IN-SOURCE-TREE-P COMPILER::ITEM COMPILER::ELEMENT))
	      (RETURN T)))))))) 


(DEFUN COMPILER::CHECK-FOR-OBSOLETE-VARIABLE (COMPILER::VARNAME)
  (WHEN (OR COMPILER::COMPILING-COMMON-LISP (NOT (BOUNDP COMPILER::VARNAME)))
    (LET ((COMPILER::NEW-NAME (GET COMPILER::VARNAME 'COMPILER::OBSOLETE-VARIABLE)))
      (COND
	((NOT (NULL COMPILER::NEW-NAME))
	 (UNLESS (OR INHIBIT-STYLE-WARNINGS-SWITCH (NOT OBSOLETE-FUNCTION-WARNING-SWITCH))
	   (COMPILER:WARN 'COMPILER::CHECK-FOR-OBSOLETE-VARIABLE :OBSOLETE
			  (IF (SYMBOLP COMPILER::NEW-NAME)
			    "~S is an obsolete name for special variable ~S."
			    "~S is an obsolete special variable; use ~A instead.")
			  COMPILER::VARNAME COMPILER::NEW-NAME)))
	((AND COMPILER:CHECK-CONFORMANCE (NOT (COMPILER::PORTABLE-SYMBOL-P COMPILER::VARNAME))
	    (GET COMPILER::VARNAME 'SPECIAL)
	    (COMPILER::IN-SOURCE-TREE-P COMPILER::VARNAME
					(OR COMPILER::SOURCE-FORM
					   (COMPILER::COMPILAND-DEFINITION
					    COMPILER::*CURRENT-COMPILAND*))))
	 (COMPILER:CONFORMANCE-WARNING "~A ~S is not portable."
				       (IF (CONSTANTP COMPILER::VARNAME)
					 "Constant"
					 "Special variable")
				       COMPILER::VARNAME)))))) 


))




#!C
; From file CONFORMANCE.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; CONFORMANCE.É#É"


(DEFUN CONFORMANCE-WARNING (FORMAT-STRING &REST FORMAT-ARGS)
  "If conformance checking is enabled, issue a warning message."
  (WHEN (AND CHECK-CONFORMANCE
	     (EQ COMPILING-COMMON-LISP T)	; Not Zetalisp, Maclisp, or Scheme
	     (NOT INHIBIT-STYLE-WARNINGS-SWITCH)
	     (NULL WARN-CATCHER)
	     QC-FILE-IN-PROGRESS ; not in COMPILE
	     ;; Avoid duplicate messages
	     (LET ((LAST-WARNING-ARGS (SI::WARNING-FORMAT-ARGS (FIRST SI::OBJECT-WARNINGS-PUSHING-LOCATION))))
	       (NOT (AND (EQUAL (FIRST LAST-WARNING-ARGS) FORMAT-STRING)
			 (EQUAL (SECOND LAST-WARNING-ARGS) FORMAT-ARGS)))))
    (LET ((SI:WARNINGS-PRINLEVEL 2))
      (WARN 'CONFORMANCE-WARNING ':NOT-PORTABLE
	    "Warning; non-standard usage: ~?" FORMAT-STRING FORMAT-ARGS))
    T))

(ADD-STYLE-CHECKER IF IF-CONFORMANCE)
(DEFUN IF-CONFORMANCE (FORM)
  (WHEN (> (LENGTH FORM) 4)
    (LET (( SI:WARNINGS-PRINLENGTH 6 ))
      (CONFORMANCE-WARNING "IF with more than 3 arguments: ~S" FORM)
      )))

(ADD-STYLE-CHECKER LISP:GET GET-CONF)
(ADD-STYLE-CHECKER CL:GET GET-CONF)
(DEFUN GET-CONF (FORM)
  (WHEN CHECK-CONFORMANCE
    (LET ((TYPE (TYPE-OF-SOURCE-EXPRESSION (SECOND FORM))))
      (WHEN (AND (NEQ TYPE T)
		 (SI:DISJOINT-TYPEP TYPE 'SYMBOL))
	(CONFORMANCE-WARNING "1st argument of GET, ~S, is not a symbol." (SECOND FORM))))))

(DEFUN TYPE-OF-SOURCE-EXPRESSION (FORM)
  (TYPECASE FORM
    (SYMBOL
     (IF (NULL FORM)
	 'NULL
       (LET ((VAR (LOOKUP-VAR FORM VARS)))
	 (IF VAR
	     (VAR-DATA-TYPE VAR)
	   (TYPE-OF-EXPRESSION FORM)))))
    (CONS (IF (ASSOC (FIRST FORM) LOCAL-FUNCTIONS :TEST #'EQ)
	      T
	    (CASE (FIRST FORM)
	      (QUOTE (TYPE-OF (SECOND FORM)))
	      (THE (SECOND FORM))
	      (OTHERWISE (GETDECL (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T)))))
    ;; Else self-evaluating form.
    (T (TYPE-OF FORM))))

(DEFPROP LOCF			LOCATIVE	FUNCTION-RESULT-TYPE)

(comment ; test
  (defun typee (form)
    (let ((vars nil)
	  (local-functions nil))
      (TYPE-OF-SOURCE-EXPRESSION form)))
  ) 

(ADD-STYLE-CHECKER FUNCTION FUNCTION-STYLE)
(DEFUN FUNCTION-STYLE (FORM)
  (WHEN (AND CHECK-CONFORMANCE
	     (IN-SOURCE-AREA-P FORM))
    (LET ((FN (SECOND FORM)))
      (TYPECASE FN
	(SYMBOL
	 (WHEN (AND (OR (NOT (PORTABLE-SYMBOL-P FN))
			(EQ FN 'IGNORE))
		    (NULL (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ))
		    (NULL (FILE-LOCAL-DEF FN)))
	   (CONFORMANCE-WARNING "Function ~S is not portable." FN)))
	(CONS
	 (COND ((MEMBER (FIRST FN) FUNCTION-START-SYMBOLS :TEST #'EQ)
		(UNLESS (EQ (FIRST FN) 'LAMBDA) ; the only one that is standard
		  (CONFORMANCE-WARNING "~S" FORM)))
	       ((AND (NOT (EQ (FIRST FN) 'SETF))
		     (VALIDATE-FUNCTION-SPEC FN))	; otherwise P1FUNCTION reports error
		(CONFORMANCE-WARNING "~S" FORM))))))))


(DEFPARAMETER *NON-PORTABLE-PACKAGE-NAMES*
	      '("BUSNET" "CHAOS" "COMPILER" "EH" "ETHERNET"
		"FED" "FILE-SYSTEM" "FONTS" "FORMAT"
		"GLOBAL" "IMAGEN" "IMAGEN-FONTS" "INSTALLER" "LX"
		"MAIL" "MATH" "METER" "MICRONET" "MT" "NAME" "NET" "NET-CONFIG" "NSE"
		"PRINTER" "PROFILE" "SRCCOM" "SUGG" "SYSLOG" "SYSTEM"
		"TELNET" "TICL" "TICLOS" "TIME" "TV" "UCL" "W" "ZLC" "ZWEI")
  "When *CONFORMANCE* is true, COMPILE-FILE will warn about symbols in these packages.")

;; This list will be created from *NON-PORTABLE-PACKAGE-NAMES* the first time 
;; PORTABLE-SYMBOL-P is called.  We don't look up the packages at load time 
;; because some of these packages are created after the compiler is loaded.
(DEFPARAMETER *NON-PORTABLE-PACKAGES* NIL)

;; Clear the list before disk saving so that we can GC any packages that may 
;; have been deleted and include any applicable packages that have been created.
(ADD-INITIALIZATION '*NON-PORTABLE-PACKAGES*
		    '(SETQ *NON-PORTABLE-PACKAGES* NIL)
		    :FULL-GC)

(DEFPARAMETER *OK-SYMBOLS* ; special cases for which PORTABLE-SYMBOL-P should return true.
	      (UNION
		;; Symbols exported from COMMON-LISP even though their home package is non-standard.
		(LET ((ANSI-PACKAGES (MAPCAR #'FIND-PACKAGE '("COMMON-LISP" "CLOS" "CONDITIONS"))))
		  (REMOVE-IF #'(LAMBDA (SYMBOL)
				 (MEMBER (SYMBOL-PACKAGE SYMBOL)
					 ANSI-PACKAGES :TEST #'EQ))
			     SYS::*ANSI-SYMBOLS*))
		;; Permit these because it is trivial to provide a dummy definition.
		'( INHIBIT-STYLE-WARNINGS DONT-OPTIMIZE
		  ;; These are used by the reader to represent backquote forms.
		  SI::XR-BQ-CONS SI::XR-BQ-LIST SI::XR-BQ-LIST* SI::XR-BQ-APPEND SI::XR-BQ-NCONC SI::XR-BQ-VECTOR
		)))

(DEFUN PORTABLE-SYMBOL-P (SYMBOL)
  (AND (OR (NOT (MEMBER (SYMBOL-PACKAGE SYMBOL)
			(OR *NON-PORTABLE-PACKAGES*
			    (SETQ *NON-PORTABLE-PACKAGES*
				  (LOOP FOR NAME IN *NON-PORTABLE-PACKAGE-NAMES*
					AS PKG = (FIND-PACKAGE NAME)
					UNLESS (NULL PKG)
					COLLECT PKG)))
			:TEST #'EQ))
	   (MEMBER SYMBOL *OK-SYMBOLS* :TEST #'EQ)
	   (AND (MEMBER CHECK-CONFORMANCE '(:LUCID :ALLEGRO)) ; both support flavors
		(OR (MEMBER SYMBOL '( COMPILE-FLAVOR-METHODS CONTINUE-WHOPPER 
				 LEXPR-CONTINUE-WHOPPER DEFFLAVOR UNDEFMETHOD 
				 DEFWHOPPER DEFWRAPPER INSTANCEP RECOMPILE-FLAVOR SELF SEND 
				 SYMEVAL-IN-INSTANCE SET-IN-INSTANCE *ALL-FLAVOR-NAMES*
				 INSTANTIATE-FLAVOR)
			:TEST #'EQ)
		    (IF (EQ CHECK-CONFORMANCE ':LUCID)
			(MEMBER SYMBOL '(DEFSUBST DISPLACED-ARRAY-P XOR))
		      (MEMBER SYMBOL '(*PRINT-STRUCTURE* FIXNUMP RATIOP ADVISE ARGLIST SI:VANILLA-FLAVOR)))))
	   )
       (CASE CHECK-CONFORMANCE
	 (:CLTL (AND (NOT (MEMBER (SYMBOL-PACKAGE SYMBOL) '#,(MAPCAR #'FIND-PACKAGE '("CLOS" "CLEH")) :TEST #'EQ))
		     (NOT (MEMBER SYMBOL SYS::*ANSI-SYMBOLS* :TEST #'EQ))))
	 (:cltl+clos (or
		       (eq (SYMBOL-PACKAGE SYMBOL) '#,(FIND-PACKAGE "CLOS"))
		       ;; may 02/01/90 Allow clos symbols even though home pkg is ticlos (in rel6)
		       ;; Most of these symbols must be special-cased because their home pkg
		       ;; is TICL or SYSTEM and cannot be moved to COMMON-LISP or CLOS because
		       ;; they are needed for flavors or other reasons.
		       (member symbol *ok-symbols* :test #'eq)
		       ;; may 02/02/90 Allow cleh symbols
		       (eq (SYMBOL-PACKAGE SYMBOL) '#,(FIND-PACKAGE "CLEH"))
		       ;; Don't allow any OTHER ANSI symbols.
		       (not (MEMBER SYMBOL SYS::*ANSI-SYMBOLS* :tEST #'EQ))))
				       
	 (:ANSI (NOT (AND (MEMBER SYMBOL SI::*NONSTANDARD-SYMBOLS* :TEST #'EQ)
			  (NOT (FBOUNDP (FIND-SYMBOL (SYMBOL-NAME SYMBOL) '#,(FIND-PACKAGE "CL")))))))
	 (OTHERWISE T) )))

(DEFUN CHECK-CONSTANT-PORTABILITY (VALUE)
  (UNLESS INHIBIT-STYLE-WARNINGS-SWITCH
    (TYPECASE VALUE
      (CHARACTER (COND ((OR (LET ((CHAR (MAKE-CHAR VALUE)))
			      (NOT (OR (STANDARD-CHAR-P CHAR)
				       ;; semi-standard characters [CLtL p. 21]
				       (MEMBER CHAR '(#\BackSpace #\Tab #\LineFeed #\Page #\Return #\Rubout)))))
			    (NOT (ZEROP (LOGAND (CHAR-BITS VALUE)
						;; Only allow the bits specified in CLtL.
						'#.(LOGNOT (LOGIOR CHAR-CONTROL-BIT CHAR-META-BIT
								   CHAR-SUPER-BIT CHAR-HYPER-BIT)))))
			    )
			(CONFORMANCE-WARNING "character constant: ~S" VALUE))
		       ((EQ CHECK-CONFORMANCE ':ANSI)
			(COND ((NOT (ZEROP (CHAR-FONT VALUE)))
			       (CONFORMANCE-WARNING "fonted character: ~S" VALUE))
			      ((NOT (ZEROP (CHAR-BITS VALUE)))
			       (CONFORMANCE-WARNING "character with attribute bits: ~S" VALUE))))))
      (CONS (WHEN (IN-SOURCE-AREA-P VALUE) ; unless produced by a macro
	      (DO ((LIST VALUE (REST LIST)))
		  ((ATOM LIST) ; could be dotted list
		   (CHECK-CONSTANT-PORTABILITY LIST))
		(CHECK-CONSTANT-PORTABILITY (FIRST LIST)))))
      (SYMBOL (UNLESS (OR (NULL VALUE)
			  (PORTABLE-SYMBOL-P VALUE)
			  (EQ (SYMBOL-PACKAGE VALUE) *PACKAGE*)
			  (AND (EQ VALUE (FIND-SYMBOL (SYMBOL-NAME VALUE) *PACKAGE*))
			       (NOT (GETL VALUE '(SUPERSEDED SUPERSEDED-BY OBSOLETE-VARIABLE)))))
		(CONFORMANCE-WARNING "symbol constant in implementation-specific package: ~S" VALUE)))
      (VECTOR (UNLESS (OR (NAMED-STRUCTURE-P VALUE)
			  (NOT (EQ (ARRAY-TYPE VALUE) 'ART-Q))
			  (IN-SOURCE-AREA-P VALUE))
		(DOTIMES (I (LENGTH VALUE))
		  (CHECK-CONSTANT-PORTABILITY (AREF VALUE I)))))
      )))

(ADD-STYLE-CHECKER TYPEP TYPEP-CHECK)
(DEFUN TYPEP-CHECK (FORM)
  (LET (ARG TYPE)
    (WHEN (AND CHECK-CONFORMANCE
	       (= (LENGTH FORM) 3)
	       (QUOTEP (SETQ ARG (THIRD FORM)))
	       (SYMBOLP (SETQ TYPE (SECOND ARG)))
	       (NOT (PORTABLE-SYMBOL-P TYPE))
	       ;; Avoid duplicating warning from CHECK-CONSTANT-PORTABILITY
	       (OR (EQ (SYMBOL-PACKAGE TYPE) *PACKAGE*)
		   (AND (EQ TYPE (FIND-SYMBOL (SYMBOL-NAME TYPE) *PACKAGE*))
			(NOT (GETL TYPE '(SUPERSEDED SUPERSEDED-BY OBSOLETE-VARIABLE)))))
	       (TYPE-SPECIFIER-P TYPE) )
      (CONFORMANCE-WARNING "type ~S in TYPEP call." TYPE))))

(ADD-STYLE-CHECKER DOCUMENTATION DOCUMENTATION-CHECK)
(DEFUN DOCUMENTATION-CHECK (FORM)
  (WHEN (AND (= (LENGTH FORM) 2)
	     (EQ (TYPE-OF-SOURCE-EXPRESSION (SECOND FORM)) 'SYMBOL))
    (CONFORMANCE-WARNING "missing second argument in ~S." FORM)))

(ADD-STYLE-CHECKER DEFVAR DEFVAR-CHECK)
(DEFUN DEFVAR-CHECK (FORM)
  (WHEN (EQ (THIRD FORM) ':UNBOUND)
    (CONFORMANCE-WARNING "DEFVAR with :UNBOUND value;
  use: (DEFVAR ~S) (SETF (DOCUMENTATION '~S 'VARIABLE) ~S)"
	 (SECOND FORM) (SECOND FORM)
	 (LET ((DOC (FOURTH FORM)))
	   (IF (AND (STRINGP DOC)
		    (> (LENGTH DOC) 20))
	       "..."
	     DOC)))))

(ADD-STYLE-CHECKER MULTIPLE-VALUE-BIND MVB-CHECK)
(ADD-STYLE-CHECKER MULTIPLE-VALUE-SETQ MVB-CHECK)
(DEFUN MVB-CHECK (FORM)
  (WHEN (MEMBER 'NIL (SECOND FORM))
    (LET ((SI:WARNINGS-PRINLENGTH 3))
      (CONFORMANCE-WARNING "NIL variable in ~S" FORM))))

(ADD-STYLE-CHECKER CLOS:DEFCLASS DEFCLASS-CHECK)
(DEFUN DEFCLASS-CHECK (FORM)
  (WHEN CHECK-CONFORMANCE
    (DESTRUCTURING-BIND (FN CLASS-NAME INCLUDES SLOT-OPTIONS &REST CLASS-OPTIONS) FORM
      (DECLARE (IGNORE FN CLASS-NAME SLOT-OPTIONS))
      (DO ((TAIL INCLUDES (REST TAIL)))
	  ((ATOM TAIL))
	(WHEN (AND (SYMBOLP (FIRST TAIL))
		   (NOT (PORTABLE-SYMBOL-P (FIRST TAIL))))
	  (CONFORMANCE-WARNING "superclass ~S." (FIRST TAIL))))
      (LET ((METACLASS (SECOND (ASSOC ':METACLASS CLASS-OPTIONS))))
	(WHEN (AND (SYMBOLP METACLASS)
		   (NOT (PORTABLE-SYMBOL-P METACLASS)))
	  (CONFORMANCE-WARNING "metaclass ~S." METACLASS)))))
  (VALUES))

;; These symbols are non-standard but have other style checkers, so they won't 
;; be handled by the default case in PRE-OPTIMIZE.
(DOLIST (FN '( DEFFLAVOR SMALL-FLOATP NAMED-STRUCTURE-P
	      DEFSUBST XOR FIXNUMP QUOTIENT LOCATIVEP))
  (ADD-STYLE-CHECKER-1 FN 'CHECK-FORM-FOR-NON-STANDARD-FUNCTION))

(DEFUN CHECK-FORM-FOR-NON-STANDARD-FUNCTION (FORM)
  (LET (FN)
    (WHEN (AND CHECK-CONFORMANCE
	       (NOT (PORTABLE-SYMBOL-P (SETQ FN (FIRST FORM))))
	       (IN-SOURCE-AREA-P FORM)
	       (NULL (FILE-LOCAL-DEF FN))
	       (NOT (EQ FN 'SI:DISPLACED)) ; DISPLACED forms are created in WORKING-STORAGE-AREA
	       )
      (CONFORMANCE-WARNING "~A ~S is not portable."
			   (COND ((MACRO-FUNCTION FN) "Macro")
				 ((SPECIAL-FORM-P FN) "Special form")
				 (T "Function"))
			   FN))))

(ADD-STYLE-CHECKER DEFMETHOD DEFMETHOD-CHECK)
(DEFUN DEFMETHOD-CHECK (FORM)
  (WHEN CHECK-CONFORMANCE
    (IF (OR (NOT (FBOUNDP 'TICLOS::FLAVOR-METHOD-SPEC-P))
	    (TICLOS::FLAVOR-METHOD-SPEC-P (SECOND FORM)))
	(UNLESS (MEMBER CHECK-CONFORMANCE '(:LUCID :ALLEGRO))
	  (LET ((SI:WARNINGS-PRINLENGTH 2))
	    (CONFORMANCE-WARNING "Flavor method ~S" FORM)))
      (LET ((ARGS (CDDR FORM)))
	(LOOP WHILE (ATOM (FIRST ARGS))
	      DO (POP ARGS))
	(DOLIST (ARG (FIRST ARGS))
	  (COND ((CONSP ARG)
		 (LET ((SPECIALIZER (SECOND ARG)))
		   (COND ((SYMBOLP (SECOND ARG))
			  (WHEN (AND (CLOS:FIND-CLASS SPECIALIZER NIL)
				     (OR (NOT (PORTABLE-SYMBOL-P SPECIALIZER))
					 ;; Standard names with non-standard class definitions:
					 (MEMBER SPECIALIZER '( FIXNUM BIGNUM COMPILED-FUNCTION
							       SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT))))
			    (CONFORMANCE-WARNING "class ~S used as method specializer." SPECIALIZER)))
			 ((TICLOS:INDIVIDUAL-TYPEP SPECIALIZER)
			  (LET ((EXP (TICLOS:INDIVIDUAL-TYPE SPECIALIZER)))
			    (COND ((QUOTEP EXP)
				   (CHECK-CONSTANT-PORTABILITY (SECOND EXP)))
				  ((SELF-EVALUATING-P EXP)
				   (CHECK-CONSTANT-PORTABILITY EXP))))))))
		((MEMBER ARG LAMBDA-LIST-KEYWORDS)
		 (RETURN)))))
      )))

(ADD-STYLE-CHECKER IN-PACKAGE IN-PACKAGE-CHECK)
(DEFUN IN-PACKAGE-CHECK (FORM)
  (WHEN (AND CHECK-CONFORMANCE
	     (NEQ CHECK-CONFORMANCE ':CLTL)
	     (QUOTEP (SECOND FORM))
	     (OR (NULL (CDDR FORM)) (EQ CHECK-CONFORMANCE ':ANSI)))
    (CONFORMANCE-WARNING "for ANSI compatibility, the first argument of IN-PACKAGE should be a string or keyword.
  e.g. ~S instead of ~S." (STRING (SECOND (SECOND FORM))) (SECOND FORM)))
  (WHEN (AND (EQ CHECK-CONFORMANCE ':ANSI)
	     (CDDR FORM))
    (CONFORMANCE-WARNING "IN-PACKAGE only takes one argument in ANSI Common Lisp.
  Use DEFPACKAGE to create the package."))
  )

(DEFUN CHECK-FORMAT-STRING (FORMAT-STRING FORM)
  ;; Check for non-standard format directives.
  (WHEN (AND (STRINGP FORMAT-STRING)
	     CHECK-CONFORMANCE)
    (LET ((I 0)
	  (L (LENGTH FORMAT-STRING))
	  (CHAR #\NULL))
      (DECLARE (TYPE STRING-CHAR CHAR))
      (LOOP (SETQ I (%STRING-SEARCH-CHAR #\~ FORMAT-STRING I L))
	    (WHEN (NULL I) (RETURN))
	    ;; Ignore any characters after "~" that are prefix modifier
	    ;; type chars applicable to many format directives, instead get
	    ;; at the primary format directive.
 	    (LOOP (WHEN (>= (INCF I) L) (RETURN-FROM CHECK-FORMAT-STRING))
		  (SETQ CHAR (char-upcase (CHAR FORMAT-STRING I)))	;; MAY 07/09/90 Moved char-upcase inside loop for "v"
		  (UNLESS (OR (POSITION CHAR ",#V:@'")
			      (DIGIT-CHAR-P CHAR))
		    (RETURN)))
	    ;; See if the primary format directive is legal
	    (UNLESS (OR (POSITION CHAR "|%&()*<>?~[]^ABCDEF$GOPRSTX{};")	;; MAY 07/09/90 Added ";"
			(EQL CHAR #\NEWLINE))
	      (CONFORMANCE-WARNING "FORMAT directive ~~~A in ~S" CHAR FORM))
	    ))))

(ADD-STYLE-CHECKER LISP:ERROR FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:ERROR FORMAT-CHECKER)
(ADD-STYLE-CHECKER LISP:CERROR FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:CERROR FORMAT-CHECKER)
(ADD-STYLE-CHECKER LISP:WARN FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:WARN FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:SIGNAL FORMAT-CHECKER)
(ADD-STYLE-CHECKER LISP:BREAK FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:BREAK FORMAT-CHECKER)
(ADD-STYLE-CHECKER CLEH:INVOKE-DEBUGGER FORMAT-CHECKER)

(DEFUN FORMAT-CHECKER (FORM)
  (WHEN CHECK-CONFORMANCE
    (CHECK-FORMAT-STRING (SECOND FORM) FORM)
    (WHEN (MEMBER (FIRST FORM) '(LISP:CERROR CLEH:CERROR))
      (CHECK-FORMAT-STRING (THIRD FORM) FORM))))

(DEFUN CHECK-FOR-STANDARD-ARGS (FORM)
  (WHEN CHECK-CONFORMANCE
    (BLOCK CHECK-ARGUMENTS
      ;; The LAMBDA-LIST is assumed to not contain &ALLOW-OTHER-KEYS
      (LET ((LAMBDA-LIST (GET (FIRST FORM) 'STANDARD-ARGLIST '(&REST X)))
	    (ARGS (REST FORM))
	    (OPTIONAL-ARG NIL))
	(DO ((TAIL LAMBDA-LIST (REST TAIL)))
	    ((NULL TAIL))
	  (IF (MEMBER (FIRST TAIL) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
	      (CASE (FIRST TAIL)
		(&OPTIONAL (SETQ OPTIONAL-ARG T))
		(&REST (POP TAIL)
		       (UNLESS (EQ (FIRST (REST TAIL)) '&KEY)
			 (RETURN-FROM CHECK-ARGUMENTS)))
		(&KEY (DO ((PAIRS ARGS (CDDR PAIRS)))
			  ((NULL PAIRS))
			(LET ((ACTUAL-KEY (IF (QUOTEP (FIRST PAIRS))
					      (SECOND (FIRST PAIRS))
					    (FIRST PAIRS))))
			  (WHEN (KEYWORDP ACTUAL-KEY)
			    (IF (EQ ACTUAL-KEY ':ALLOW-OTHER-KEYS)
				(UNLESS (EQ (TYPE-OF-SOURCE-EXPRESSION (SECOND PAIRS)) 'NULL)
				  (RETURN-FROM CHECK-ARGUMENTS))
			      (UNLESS (MEMBER ACTUAL-KEY (REST TAIL) :TEST #'EQ)
				(CONFORMANCE-WARNING "keyword argument ~S in ~S" ACTUAL-KEY FORM))))))
		      (RETURN-FROM CHECK-ARGUMENTS))
		((&AUX &EXTENSION) (RETURN)))
	    (IF (NULL ARGS)
		(PROGN (UNLESS OPTIONAL-ARG
			 (CONFORMANCE-WARNING "Not enough arguments in ~S" FORM))
		       (RETURN-FROM CHECK-ARGUMENTS))
	      (POP ARGS))))
	(UNLESS (NULL ARGS)
	  (CONFORMANCE-WARNING "Too many arguments in ~S" FORM))
	)))
  (VALUES))

(DEFMACRO STANDARD-FUNCTION (NAME ARGLIST)
  ;; Declare the standard lambda list for conformance checking on calls to function NAME.
  (DECLARE (ARGLIST &QUOTE NAME ARGLIST))
  (LET* ((ARGLIST (COPY-LIST ARGLIST))
	 (KEYLIST (MEMBER '&KEY ARGLIST)))
    (IF (MEMBER '&ALLOW-OTHER-KEYS KEYLIST)
	(SETF (FIRST KEYLIST) '&REST
	      (REST KEYLIST) '(X))
      (DO ((ARGS (REST KEYLIST) (REST ARGS)))
	  ((NULL ARGS))
	(WHEN (CONSP (FIRST ARGS))
	  (SETF (FIRST ARGS) (FIRST (FIRST ARGS))))
	(UNLESS (KEYWORDP (FIRST ARGS))
	  (SETF (FIRST ARGS) (INTERN (FIRST ARGS) *KEYWORD-PACKAGE*)))))
    `(PROGN (DEFPROP ,NAME ,ARGLIST STANDARD-ARGLIST)
	    (ADD-STYLE-CHECKER ,NAME CHECK-FOR-STANDARD-ARGS))
    ))
	
(STANDARD-FUNCTION MAKE-ARRAY
		   ( DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS
		    :ADJUSTABLE :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET))

(STANDARD-FUNCTION MAKE-SYMBOL (NAME))
(STANDARD-FUNCTION RATIONALIZE (NUMBER))
(STANDARD-FUNCTION MAKE-PACKAGE (NAME &KEY :NICKNAMES :USE))
(STANDARD-FUNCTION IN-PACKAGE   (NAME &KEY :NICKNAMES :USE))
(STANDARD-FUNCTION MAKE-LIST (SIZE &KEY :INITIAL-ELEMENT))
(STANDARD-FUNCTION STRING-CAPITALIZE (STRING &KEY :START :END))
(STANDARD-FUNCTION MAKE-HASH-TABLE (&KEY :TEST :SIZE :REHASH-SIZE :REHASH-THRESHOLD))
(STANDARD-FUNCTION MAPHASH (FUNCTION HASH-TABLE))
(STANDARD-FUNCTION SXHASH (OBJECT))
(STANDARD-FUNCTION SUBTYPEP (A B))
(STANDARD-FUNCTION FUNCTIONP (OBJECT))
(STANDARD-FUNCTION COMPILE-FILE (INPUT &KEY :OUTPUT-FILE :VERBOSE :PRINT))
(STANDARD-FUNCTION MAKE-STRING-OUTPUT-STREAM ())
(STANDARD-FUNCTION MAKE-PATHNAME (&KEY :HOST :DEVICE :DIRECTORY :NAME TYPE :VERSION :DEFAULTS))
(STANDARD-FUNCTION USER-HOMEDIR-PATHNAME (&OPTIONAL HOST))
(STANDARD-FUNCTION RENAME-FILE (S NAME))
(STANDARD-FUNCTION DELETE-FILE (S))
(STANDARD-FUNCTION LOAD (FILE &KEY :VERBOSE :PRINT :IF-DOES-NOT-EXIST))
(STANDARD-FUNCTION READ (&OPTIONAL STREAM EOF-ERRORP EOF-VALUE RECURSIVEP))
(STANDARD-FUNCTION READ-BYTE (STREAM &OPTIONAL EOF-ERRORP EOF-VALUE))
(STANDARD-FUNCTION WRITE-BYTE (INTEGER STREAM))

(ADD-STYLE-CHECKER DEFSTRUCT STRUCT-CONFORM)
(DEFUN STRUCT-CONFORM (FORM)
  (WHEN CHECK-CONFORMANCE
    (LET ((OPTIONS (AND (CONSP (SECOND FORM)) (REST (SECOND FORM))))
	  (SLOTS (CDDR FORM)))
      (WHEN (STRINGP (FIRST SLOTS)) (POP SLOTS))
      (DOLIST (OPTION OPTIONS)
	(WHEN (TYPECASE OPTION
		(CONS (CASE (FIRST OPTION)
			(:TYPE (AND (SYMBOLP (SECOND OPTION))
				    (GET (SECOND OPTION) 'SI::DEFSTRUCT-TYPE-DESCRIPTION)
				    (NOT (MEMBER (SECOND OPTION) '(VECTOR LIST)))))
			(( :TIMES :SUBTYPE :ALTERANT :DEFAULT-POINTER :MAKE-ARRAY :SIZE-MACRO 
			  :SIZE-SYMBOL :BUT-FIRST :CALLABLE-ACCESSORS :CALLABLE-CONSTRUCTORS :PROPERTY :PRINT)
			 T)
			))
		(SYMBOL (GET OPTION 'SI::DEFSTRUCT-TYPE-DESCRIPTION NIL)))
	  (CONFORMANCE-WARNING "DEFSTRUCT option ~S" OPTION)))	 
      (DOLIST (SLOT SLOTS)
	(WHEN (CONSP SLOT)
	  (WHEN (CONSP (FIRST SLOT))
	    (CONFORMANCE-WARNING "byte-field slot ~S" SLOT))
	  (WHEN (GETF (CDDR SLOT) :DOCUMENTATION)
	    (CONFORMANCE-WARNING "DEFSTRUCT slot option :DOCUMENTATION"))
	  ))
      )))

(ADD-STYLE-CHECKER LOOP LOOP-CHECK)
(DEFUN LOOP-CHECK (FORM)
  (WHEN (AND (EQ CHECK-CONFORMANCE ':CLTL)
	     (SYMBOLP (SECOND FORM)))
    (CONFORMANCE-WARNING "extended LOOP macro: ~S" FORM)))

;; This behaves the same as CL:IGNORE-ERRORS, so suppress conformance warning.
(ADD-STYLE-CHECKER TICL:IGNORE-ERRORS ERRORS-CHECK)
(DEFUN ERRORS-CHECK (FORM)
  (WHEN (EQ CHECK-CONFORMANCE ':CLTL)
    (CHECK-FORM-FOR-NON-STANDARD-FUNCTION FORM)))

(ADD-STYLE-CHECKER IGNORE IGNORE-CHECK)
(DEFUN IGNORE-CHECK (FORM)
  (CONFORMANCE-WARNING "IGNORE used as a function in ~S; use IGNORE declaration instead." FORM))


))



#!C
; From file MACLISP.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; MACLISP.É#É"



(DEFUN COMPILER::NOT-MACLISP (COMPILER::FORM)
  (IF RUN-IN-MACLISP-SWITCH
    (COMPILER:WARN 'COMPILER::NOT-IN-MACLISP ':MACLISP "~S is not implemented in Maclisp."
		   (CAR COMPILER::FORM))
    (COMPILER::CHECK-FORM-FOR-NON-STANDARD-FUNCTION COMPILER::FORM))) 


))


#!C
; From file TYPEOPT.LISP#> COMPILER; SYS:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.É#É"

(DEFUN ADD-OPTIMIZE-PATTERN ( FUNCTION-NAME TEMPLATE REPLACEMENT
			     &OPTIONAL (PERMUTATIONS NIL) (CONDITION T))
  ;;  6/21/86 DNG - Modified to include the pattern list in the POST-OPTIMIZERS
  ;;		 property instead of as a separate property.
  ;;  7/17/86 DNG - Support optional CONDITION argument.
  ;;  7/21/86 DNG - Update existing pattern when either condition or replacement match.
  ;;  4/13/89 DNG - Adding setting of the OPTIMIZED-INTO property.
  ;; 10/27/89 DNG - Don't record OPTIMIZED-INTO with value of PROGN or 
  ;;		FUNCALL.  [The P2 property for these is not defined until after this 
  ;;		file is loaded.]
  (LET* (( PROP (GET FUNCTION-NAME 'POST-OPTIMIZERS) )
	 ( POSTOPT
	  (AND (CONSP PROP)
	       (DOLIST ( X PROP NIL )
		 (WHEN (AND (CONSP X)
			    (EQ (FIRST X) 'PATTERN-OPTIMIZER))
		   (RETURN X)))) )
	 ( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))
    (UNLESS (OR (NULL CONDITION) (ATOM REPLACEMENT))
      (LET ((INTO (CAR REPLACEMENT)))
	(WHEN (AND (SYMBOLP INTO)
		   (NOT (GET INTO 'P2))
		   (NOT (EQ INTO FUNCTION-NAME))
		   (NOT (MEMBER INTO '(PROGN FUNCALL))))
	  (PUSH-NEW-PROPERTY FUNCTION-NAME INTO 'OPTIMIZED-INTO))))
    (DOLIST ( P (SECOND POSTOPT) )
      (WHEN (AND (EQUAL TEMPLATE (FIRST P))
		 (OR (EQUAL REPLACEMENT (SECOND P))
		     (EQUAL CONDITION
			    (IF (CDDDR P) (FOURTH P) T))))
	;; Update existing pattern list
	(UNLESS (EQUAL REPLACEMENT (SECOND P))
	  (SETF (SECOND P) REPLACEMENT))
	(UNLESS (EQUAL PERMUTATIONS (THIRD P))
	  (SETF (THIRD P)  PERMUTATIONS))
	(UNLESS (EQUAL CONDITION (FOURTH P))
	  (IF (< (LENGTH P) 4)
	      (SETF (CDDDR P) (LIST CONDITION))
	    (SETF (FOURTH P) CONDITION)))
	(RETURN-FROM ADD-OPTIMIZE-PATTERN FUNCTION-NAME) ))
    (UNLESS (NULL CONDITION)
      ;; Define new pattern list
      (LET (( PATTERN (LIST TEMPLATE REPLACEMENT PERMUTATIONS CONDITION) ))
	(IF POSTOPT
	    (PUSH PATTERN (SECOND POSTOPT))
	  ;; Use FUNCALL to force the argument to be evaluated even though
	  ;; ADD-POST-OPTIMIZER is a special form.
	  (FUNCALL #'ADD-POST-OPTIMIZER FUNCTION-NAME
		   (LIST 'PATTERN-OPTIMIZER (LIST PATTERN)))))))
  FUNCTION-NAME )

(DEFUN EXPR-TYPE-P ( ORIGINAL-FORM TYPE )
  "Test whether a Lisp form [after P1] always produces a value of the indicated type."
  ;; When the second argument is a type specifier, return true if the value of
  ;;   FORM is known to always be of type TYPE.
  ;; When the second argument is RETURN-THE-TYPE, return a type specifier for
  ;;   the type of FORM, or T if no type information is available.  This should only
  ;;   be used by the macro TYPE-OF-EXPRESSION.
  ;; Note: the type NIL indicates a form that does not return [for example, GO].
  ;;
  ;;  4/21/86 - Original for release 3.
  ;;  4/28/86 - Add special handling for DEFCONSTANT symbols.
  ;;  5/08/86 - Add special handling for COND form.
  ;;  5/10/86 - Add special handling for PROGN, PROG1, etc.
  ;;  6/30/86 - Re-designed, combining EXPR-TYPE-P and TYPE-OF-EXPRESSION.
  ;;  8/09/86 - Replaced use of UNKNOWN with T [except in THE-EXPR].
  ;;  8/26/86 - Get type of BREAKOFF-FUNCTION from COMPILAND-PLIST.
  ;;  8/29/86 - Use array element type.
  ;; 10/11/86 - For a local variable which is not altered, can get type from initial value.
  ;; 11/05/87 - Check (SI:TYPE-SPECIFIER-P FORM-TYPE) before doing (TYPEP 'NIL FORM-TYPE). [SPR 6875]
  ;;  2/24/88 - If OPT-SAFETY is 3, do not allow optimizations. [SPR 7312]
  ;;  2/17/89 - Add recognition of MAKE-INSTANCE.
  ;;  4/10/89 - Use new function VAR-INIT-FORM .
  ;;  4/17/89 - Recognize that (FORMAT NIL ...) returns a string.
  ;;  4/25/89 - Add handling for %STANDARD-INSTANCE-REF and STANDARD-INSTANCE-ACCESS.
  ;;  4/26/89 - Add handling for %LET and %LET*.
  ;;  4/28/89 - Add use of *LOOP-VAR-BIT* to criteria for using the initial 
  ;;		value of a local variable.  Add special handling for SELF in a flavor 
  ;;		method.
  ;;  5/02/89 - Add handling for calls to SETF and LOCF functions.
  ;;  5/05/89 - Add handling for SET-AR-1 etc.
  ;;  5/09/89 - Check VAR-USE-COUNT before *LOOP-VAR-BIT* so it doesn't trap 
  ;;		on that variable being unbound when called from P2SELECT.
  ;;  8/15/89 - Use TICLOS::SLOT-NAME instead of SLOT-DEFINITION-NAME because 
  ;;		of bootstrapping problems while building CLOS.
  (DECLARE (ARGLIST FORM TYPE))
  (LET ( (FORM ORIGINAL-FORM) FORM-TYPE FORM-VALUE (THE-EXPR-FORM NIL) )
    (TAGBODY
	
	(WHEN (NULL FORM) ; if run past end of argument list then match fails.
	  #+compiler:debug
	  (assert (not (EQL TYPE RETURN-THE-TYPE)))
	  (RETURN-FROM EXPR-TYPE-P NIL) )
	(WHEN (EQ TYPE 'T)		   ; T matches anything
	  (RETURN-FROM EXPR-TYPE-P T) )
	
     START-OVER-WITH-NEW-FORM
	
	(IF (ATOM FORM)
	    (COND ((AND (SYMBOLP FORM)
			(GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)
			(BOUNDP-FOR-TARGET FORM))
		   ;; Check value of DEFCONSTANT
		   (SETQ FORM-VALUE (SYMEVAL-FOR-TARGET FORM))
		   (GO VALUE-KNOWN) )
		  ((OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
		       (> (OPT-SAFETY OPTIMIZE-SWITCH)
			  (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))
		   ;; Don't rely on user's declarations.
		   (GO NOTHING-KNOWN))
		  ((EQ FORM 'SELF)
		   (IF (AND SELF-FLAVOR-DECLARATION ; in a flavor method
			    (NULL (LOOKUP-VAR FORM))) ; a free reference
		       (PROGN (SETQ FORM-TYPE (CAR SELF-FLAVOR-DECLARATION))
			      (GO TYPE-KNOWN))
		     (GO NOTHING-KNOWN)))
		  ;; Else fetch the variable's type declaration.
		  ((SYMBOLP FORM)
		   (SETQ FORM-TYPE
			 (IF (OR UNDO-DECLARATIONS-FLAG LOCAL-DECLARATIONS)
			     (GETDECL FORM 'VARIABLE-TYPE 'T)
			   (GET-FOR-TARGET FORM 'VARIABLE-TYPE 'T)))
		   (GO TYPE-KNOWN))
		  (T (BARF FORM 'TYPE-OF-EXPRESSION 'BARF)))
	  (CASE (FIRST FORM)
		( QUOTE
		 (SETQ FORM-VALUE (SECOND FORM))
		 (GO VALUE-KNOWN) )
		( LOCAL-REF		   ; local variable
		 (IF (OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
			 (> (OPT-SAFETY OPTIMIZE-SWITCH)
			    (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))
		     ;; Don't rely on user's declarations.
		     (GO NOTHING-KNOWN)
		   ;; Else fetch the variable's type declaration.
		   (LET ((V (SECOND FORM)))
		     (SETQ FORM-TYPE (VAR-DATA-TYPE V))
		     (WHEN (AND (EQ FORM-TYPE 'T)
				(MEMBER (VAR-INIT-KIND V) '(FEF-INI-COMP-C FEF-INI-SETQ)) ; not an argument
				;; If there is no possibility that the value has been altered,
				;; we can use the type of the initial value expression.
				(OR (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
				    (AND (MEMBER (VAR-USE-COUNT V) '(NIL 0)) ; no assignment yet
					 (>= (CDDR FORM) *LOOP-VAR-BIT*)) ; not in a loop
				    (EQ (VAR-NAME V) '.VALUE.) ; used in type checking code
				    ))
		       (SETQ FORM (VAR-INIT-FORM V))
		       (GO START-OVER-WITH-NEW-FORM))
		     (GO TYPE-KNOWN))))
		( VALUES
		 (RETURN-FROM EXPR-TYPE-P
		   (COND ((AND (CONSP TYPE)
			       (EQ (FIRST TYPE) 'VALUES))
			  (EVERY #'EXPR-TYPE-P (REST FORM) (REST TYPE)))
			 ((AND (CDR FORM) (NULL (CDDR FORM)))
			  (SETQ FORM (SECOND FORM))
			  (GO START-OVER-WITH-NEW-FORM))
			 ((EQL TYPE RETURN-THE-TYPE)
			  (CONS 'VALUES
				(MAPCAR #'TYPE-OF-EXPRESSION (REST FORM)) ))
			 (T NIL))))
		( SETQ
		 (DO ((ARGS (REST FORM) (CDDR ARGS)))
		     ((NULL (CDDR ARGS))
		      (RETURN-FROM EXPR-TYPE-P
			(IF (EQL TYPE RETURN-THE-TYPE)
			    (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (SECOND ARGS)) ))
			      (IF (EQ EXP-TYPE 'T)
				  (PROGN (SETQ FORM (FIRST ARGS))
					 (GO START-OVER-WITH-NEW-FORM))
				EXP-TYPE ))
			  (OR (EXPR-TYPE-P (SECOND ARGS) TYPE)
			      (EXPR-TYPE-P (FIRST ARGS) TYPE)))))
		   ))
		(( PROGN PROGN-WITH-DECLARATIONS LET LET* %LET %LET*
		  SET-AR-1 SET-AR-2 SET-AR-3 SET-AREF)
		 ;; use type of last argument
		 (SETQ FORM (CAR (LAST (CDR FORM))))
		 (GO START-OVER-WITH-NEW-FORM))
		(( PROG1 SUBSEQ COPY-SEQ REVERSE NREVERSE REMOVE-DUPLICATES DELETE-DUPLICATES )
		 ;; use type of first argument
		 (SETQ FORM (SECOND FORM))
		 (GO START-OVER-WITH-NEW-FORM))
		( COND
		 (LET (( LAST-TEST NIL ))
		   (IF (EQL TYPE RETURN-THE-TYPE)
		       (PROGN
			 (DOLIST ( CLAUSE (REST FORM) )
			   (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (FIRST (LAST CLAUSE))) ))
			     (COND ((EQ EXP-TYPE 'T)
				    (SETQ FORM-TYPE EXP-TYPE)
				    (GO TYPE-KNOWN))
				   ((NULL FORM-TYPE)
				    (SETQ FORM-TYPE EXP-TYPE))
				   ((EQUAL FORM-TYPE EXP-TYPE))
				   ((SUBTYPEP EXP-TYPE FORM-TYPE *COMPILE-FILE-ENVIRONMENT*))
				   ((SUBTYPEP FORM-TYPE EXP-TYPE *COMPILE-FILE-ENVIRONMENT*)
				    (SETQ FORM-TYPE EXP-TYPE))
				   ((EQ (CAR-SAFE FORM-TYPE) 'OR)
				    (SETQ FORM-TYPE `(OR ,EXP-TYPE . ,(REST FORM-TYPE))))
				   (T (SETQ FORM-TYPE `(OR ,EXP-TYPE ,FORM-TYPE))) ))
			   (SETQ LAST-TEST (FIRST CLAUSE)) )
			 (UNLESS (OR (ALWAYS-TRUE LAST-TEST)
				     (AND (TYPE-SPECIFIER-P FORM-TYPE *COMPILE-FILE-ENVIRONMENT*)
					  ;; FORM-TYPE acceptable to TYPEP [could be (VALUES ...) or (FUNCTION ...)]
					  (TYPEP 'NIL FORM-TYPE)))
			   (SETQ FORM-TYPE `(OR NULL ,FORM-TYPE)))
			 (GO TYPE-KNOWN) )
		     (PROGN
		       (DOLIST ( CLAUSE (REST FORM) )
			 (UNLESS (EXPR-TYPE-P (FIRST (LAST CLAUSE)) TYPE)
			   (RETURN-FROM EXPR-TYPE-P NIL))
			 (SETQ LAST-TEST (FIRST CLAUSE)) )
		       (RETURN-FROM EXPR-TYPE-P
			 (IF (ALWAYS-TRUE LAST-TEST)
			     T
			   (TYPEP 'NIL TYPE) ))))))
		( THE-EXPR
		 (LET (( EXP-TYPE (EXPR-TYPE FORM) ))
		   (IF (EQ EXP-TYPE 'UNKNOWN)
		       (PROGN (SETQ THE-EXPR-FORM FORM)
			      (SETQ FORM (EXPR-FORM FORM))
			      (GO START-OVER-WITH-NEW-FORM))
		     (PROGN (SETQ FORM-TYPE EXP-TYPE)
			    (GO TYPE-KNOWN)))))
		(( FUNCALL APPLY LEXPR-FUNCALL REDUCE )
		 (LET (( FN (SECOND FORM) ))	   ; function to be called
		   (IF (AND (CONSP FN)
			    (OR (EQ (FIRST FN) 'FUNCTION)
				(EQ (FIRST FN) 'QUOTE)))
		       (IF (SYMBOLP (SECOND FN))
			   (PROGN
			     (SETQ FORM-TYPE
				   (GETDECL (SECOND FN) 'FUNCTION-RESULT-TYPE 'T))
			     (GO TYPE-KNOWN))
			 (CASE (CAR-SAFE (SECOND FN))
			   ( SETF (SETQ FORM (THIRD FORM))
				  (GO START-OVER-WITH-NEW-FORM))
			   ( LOCF (SETQ FORM-TYPE 'LOCATIVE)
				  (GO TYPE-KNOWN))
			   (OTHERWISE (GO NOTHING-KNOWN))))
		     (LET (( FT (TYPE-OF-EXPRESSION FN) ))
		       (IF (AND (CONSP FT)
				(EQ (FIRST FT) 'FUNCTION)
				(CDDR FT))
			   (PROGN (SETQ FORM-TYPE (THIRD FT))
				  (GO TYPE-KNOWN))
			 (GO NOTHING-KNOWN) )))))
		( COERCE
		 (IF (QUOTEP (THIRD FORM))
		     (PROGN (SETQ FORM-TYPE (SECOND (THIRD FORM)))
			    (GO TYPE-KNOWN))
		   (GO NOTHING-KNOWN) ))
		(( CONCATENATE MAKE-SEQUENCE MAP )
		 (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))
				     (OR (SECOND (SECOND FORM)) 'NULL) ; (MAP 'NIL ...)=>NIL
				   'SEQUENCE))
		 (GO TYPE-KNOWN))
		(( REMOVE DELETE REMOVE-IF REMOVE-IF-NOT DELETE-IF DELETE-IF-NOT )
		 ;; result has same type as second argument
		 (SETQ FORM (THIRD FORM))
		 (GO START-OVER-WITH-NEW-FORM) )
		( BREAKOFF-FUNCTION
		 ;; get type saved by REF-LOCAL-FUNCTION-VAR 
		 (SETQ FORM-TYPE
		       (GETF (COMPILAND-PLIST (SECOND FORM)) 'TYPE 'FUNCTION))
		 (GO TYPE-KNOWN))
		(( COMMON-LISP-AR-1 COMMON-LISP-AR-2 COMMON-LISP-AR-3 AREF GLOBAL:AR-1 AR-2 )
		 (LET ((ARRAY-TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))
		  (COND ((AND (CONSP ARRAY-TYPE)
			      (MEMBER (FIRST ARRAY-TYPE) '(ARRAY VECTOR SIMPLE-ARRAY))
			      (NOT (MEMBER (SECOND ARRAY-TYPE) '(T * NIL))))
			 (SETQ FORM-TYPE (SECOND ARRAY-TYPE))
			 (GO TYPE-KNOWN))
			((EQ ARRAY-TYPE 'STRING)
			 (SETQ FORM-TYPE (IF (EQ (FIRST FORM) 'GLOBAL:AR-1)
					     'FIXNUM
					   'CHARACTER))
			 (GO TYPE-KNOWN))
			(T (GO NOTHING-KNOWN)))))
		( MAKE-INSTANCE
		 (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))
				     (SECOND (SECOND FORM))
				   '(NOT NULL)))
		 (GO TYPE-KNOWN))
		( %STANDARD-INSTANCE-REF
		 ;; (%STANDARD-INSTANCE-REF object mapping-table class-name slot-name)
		 (LET* ((CLASS (TICLOS:CLASS-NAMED (FOURTH FORM) T *COMPILE-FILE-ENVIRONMENT*))
			(SD (AND CLASS (FIND (FIFTH FORM) (IF (CLOS:CLASS-FINALIZED-P CLASS)
							      (TICLOS:CLASS-SLOTS CLASS)
							    (TICLOS:CLASS-DIRECT-SLOTS CLASS))
					     :KEY #'TICLOS::SLOT-NAME :TEST #'EQ))))
		   (IF (NULL SD)
		       (GO NOTHING-KNOWN)
		     (PROGN (SETQ FORM-TYPE (TICLOS::SLOT-TYPE SD))
			    (GO TYPE-KNOWN)))))
		( TICLOS:STANDARD-INSTANCE-ACCESS 
		 ;; (STANDARD-INSTANCE-ACCESS object slot-name)
		 (IF (QUOTEP (THIRD FORM))
		     (LET ((TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))
		       (IF (EQ TYPE 'T)
			   (GO NOTHING-KNOWN)
			 (LET* ((CLASS (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*))
				(SD (AND CLASS (FIND (SECOND (THIRD FORM))
						     (IF (TICLOS:CLASS-FINALIZED-P CLASS)
							 (TICLOS:CLASS-SLOTS CLASS)
						       (TICLOS:CLASS-DIRECT-SLOTS CLASS))
						     :KEY #'TICLOS::SLOT-NAME :TEST #'EQ))))
			   (IF (NULL SD)
			       (GO NOTHING-KNOWN)
			     (PROGN (SETQ FORM-TYPE (TICLOS:SLOT-DEFINITION-TYPE SD))
				    (GO TYPE-KNOWN))))))
		   (GO NOTHING-KNOWN)))
		( THE
		 (SETQ FORM-TYPE (SECOND FORM))
		 (GO TYPE-KNOWN))
		( FORMAT
		 (IF (EQUAL (SECOND FORM) '(QUOTE NIL))
		     (PROGN (SETQ FORM-TYPE 'STRING) (GO TYPE-KNOWN))
		   (GO NOTHING-KNOWN)))
		(OTHERWISE
		 (SETQ FORM-TYPE
		       (IF (OR (EQ UNDO-DECLARATIONS-FLAG 'FUNCTION-RESULT-TYPE)
			       LOCAL-DECLARATIONS)
			   (GETDECL (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T)
			 (GET-FOR-TARGET (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T)))
		 (GO TYPE-KNOWN))
		))
	
     TYPE-KNOWN
	(WHEN THE-EXPR-FORM
	  ;; Record what we learned so we won't have to traverse that tree again.
	  (SETF (EXPR-TYPE THE-EXPR-FORM) FORM-TYPE))
	(RETURN-FROM EXPR-TYPE-P
	  (COND ((EQL TYPE RETURN-THE-TYPE)
		 FORM-TYPE)
		;; To save time, try to handle the simple cases here without calling SUBTYPE.
		((EQ FORM-TYPE 'T) NIL)
		((EQ FORM-TYPE 'NIL) T)
		((EQUAL FORM-TYPE TYPE) T)
		((AND (CONSP FORM-TYPE)
		      (EQ (FIRST FORM-TYPE) TYPE))
		 T)
		;; SUBTYPEP doesn't handle VALUES type specifiers
		((EQ (CAR-SAFE FORM-TYPE) 'VALUES)
		 (COND ((EQ (CAR-SAFE TYPE) 'VALUES)
			(EVERY #'SUBTYPEP (REST FORM-TYPE) (REST TYPE)))
		       ((NULL (REST FORM-TYPE)) NIL)
		       (T (SUBTYPEP (SECOND FORM-TYPE) TYPE *COMPILE-FILE-ENVIRONMENT*))))
		;; Not obvious; have to do it the hard way.
		(T (SUBTYPEP FORM-TYPE TYPE *COMPILE-FILE-ENVIRONMENT*) )))
	
     NOTHING-KNOWN
        (RETURN-FROM EXPR-TYPE-P
	  (IF (EQL TYPE RETURN-THE-TYPE)
	      'T
	    NIL))			   ; match fails
	
     VALUE-KNOWN
	(RETURN-FROM EXPR-TYPE-P
          (IF (EQL TYPE RETURN-THE-TYPE)
	      (IF (NULL FORM-VALUE)
		  'NULL
		(TYPE-OF FORM-VALUE))
	    (TYPEP FORM-VALUE TYPE) ))
	))) 


(DEFUN CANONICALIZE-TYPE-FOR-COMPILER ( TYPE &OPTIONAL CONTEXT VALUES-PERMITTED-P )
  ;;  8/29/86 DNG - Original.
  ;; 10/07/86 DNG - New optional arg VALUES-PERMITTED-P.
  ;;  2/11/87 DNG - For a valid type that is not a subtype of any INTERESTING-TYPES,
  ;;		return T instead of the canonicalized type since it is not of any
  ;;		use for optimization but might lead to trouble when checking initial
  ;;		values against their type declarations.
  ;;  7/08/87 DNG - Fix to accept FUNCTION types.  [SPR 5777]
  ;;  9/29/87 DNG - Fix for FUNCTION in OR types.  [SPR 6572]
  ;;  1/16/88 DNG - Add handling for name defined by DEFTYPE to be a FUNCTION 
  ;;		type. [SPR 6977]  Permit returning (FUNCTION ...) type list since 
  ;;		EXPR-TYPE-P can now handle it.
  ;;  4/07/88 DNG - Use GETDECL instead of GET.  [SPR 7746]
  ;;  8/15/88 DNG - Return CLOS class names instead of T.
  ;; 10/25/88 DNG - Reference BUILT-IN-CLASS instead of STANDARD-TYPE-CLASS.
  ;; 12/19/88 DNG - Suppress warning on undefined types in a DEFSUBST.  [SPR 9150]
  ;;  4/25/89 DNG - Permit returning a class object.
  ;;  6/15/89 DNG - Make sure *CURRENT-COMPILAND* is not NIL before testing 
  ;;		COMPILAND-SUBST-FLAG.  [SPR 9940]
  ;;  8/10/89 DNG - Don't return ARRAY for DEFSTRUCT types so that SLOT-VALUE 
  ;;		optimizations can be done on them.
  ;; 10/31/89 DNG - Add use of CHECK-CONFORMANCE and CONFORMANCE-WARNING .
 (MULTIPLE-VALUE-BIND (USABLEP LEGALP)
      (TYPE-SPECIFIER-P TYPE *COMPILE-FILE-ENVIRONMENT*)
  (COND (USABLEP ; fully defined
	 (WHEN (AND CHECK-CONFORMANCE
		    (SYMBOLP TYPE)
		    (NOT (PORTABLE-SYMBOL-P TYPE))
		    (NOT (EQ (SYMBOL-PACKAGE TYPE) *PACKAGE*))
		    (OR (ATOM CONTEXT) (IN-SOURCE-AREA-P CONTEXT)))
	   (CONFORMANCE-WARNING "type ~S in ~S" TYPE CONTEXT))
	 (IF (AND (SYMBOLP TYPE)
		  (OR (MEMBER TYPE INTERESTING-TYPES :TEST #'EQ)
		      (GET TYPE 'SI::DEFSTRUCT-DESCRIPTION)))
	     TYPE
	   (LET ((CANONIZED (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*)))
	     (DOLIST (X INTERESTING-TYPES)
	       (WHEN (SUBTYPEP CANONIZED X *COMPILE-FILE-ENVIRONMENT*)
		 (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER
		   (IF (AND (MEMBER X '(ARRAY VECTOR))
			    (CONSP CANONIZED)
			    (NOT (MEMBER (SECOND CANONIZED) '(T * NIL))))
		       (LIST* (FIRST CANONIZED)
			      (CANONICALIZE-TYPE-FOR-COMPILER (SECOND CANONIZED) TYPE)
			      (CDDR CANONIZED))
		     X))))
	     (LET ((CLASS (IF (SYS:CLASSP TYPE)
			      TYPE
			    (AND (SYMBOLP TYPE)
				 (FBOUNDP 'TICLOS:CLASS-NAMED)
				 (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*)))))
	       (COND ((NULL CLASS) T)
		     ((TYPEP-STRUCTURE-OR-FLAVOR CLASS 'TICLOS:BUILT-IN-CLASS) T)
		     (T CLASS))))))
	 ((AND (CONSP TYPE)
	       (EQ (CAR TYPE) 'VALUES)
	       VALUES-PERMITTED-P)
	  (IF (= (LENGTH TYPE) 2)
	      (CANONICALIZE-TYPE-FOR-COMPILER (SECOND TYPE) CONTEXT NIL)
	    (CONS 'VALUES
		  (LOOP FOR ITEM IN (CDR TYPE)
			IF (MEMBER ITEM '(&OPTIONAL &REST &KEY))
			;; legal but not worth bothering with
			DO (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER 'UNKNOWN)
			ELSE
			COLLECT (CANONICALIZE-TYPE-FOR-COMPILER ITEM CONTEXT NIL)))))
	 ((EQ TYPE 'FUNCTION)
	  ;; Legal for declarations even though TYPEP doesn't currently accept it [ref SPR 5778].
	  T) ; not currently interesting.
	 ((AND (CONSP TYPE)
	       (EQ (FIRST TYPE) 'FUNCTION)
	       (= (LENGTH TYPE) 3)
	       (LISTP (SECOND TYPE)))
	  ;; Legal for declarations even though TYPEP doesn't accept it.
	  (LIST (FIRST TYPE)
		(LET ((KEY NIL))
		  (LOOP FOR ITEM IN (SECOND TYPE)	; argument types
			COLLECT (COND ((MEMBER ITEM LAMBDA-LIST-KEYWORDS :TEST #'EQ)
				       (WHEN (EQ ITEM '&KEY) (SETQ KEY T))
				       ITEM)
				      ((AND KEY (LISTP ITEM) (SYMBOLP (FIRST ITEM)))
				       (LIST (FIRST ITEM)
					     (CANONICALIZE-TYPE-FOR-COMPILER (SECOND ITEM) TYPE)))
				      (T (CANONICALIZE-TYPE-FOR-COMPILER ITEM TYPE)))))
		(CANONICALIZE-TYPE-FOR-COMPILER (THIRD TYPE) TYPE T) ; result type
		))
	 (LEGALP
	  ;; Here for a SATISFIES type that uses a predicate that isn't defined yet.
	  ;; The compiler doesn't have any use for SATISFIES types anyway.
	  T)
	 ((AND (SYMBOLP TYPE)
	       (GETDECL TYPE 'SI:TYPE-EXPANDER NIL *COMPILE-FILE-ENVIRONMENT*))
	  ;; Here for a name defined by DEFTYPE to be a FUNCTION type.  [SPR 6977]
	  (CANONICALIZE-TYPE-FOR-COMPILER (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*)
					  CONTEXT VALUES-PERMITTED-P))
	 ((AND (MEMBER (CAR-SAFE TYPE) '(OR AND) :TEST #'EQ)
	       (CONSP (CDR TYPE)))
	  ;; If one of the elements of the OR is a FUNCTION type, TYPE-SPECIFIER-P 
	  ;; will have rejected it, but we still need to allow it.  [SPR 6572]
	  (LET ((UNION NIL))
	    (DOLIST (X (REST TYPE))
	      (LET ((CANONIZED (CANONICALIZE-TYPE-FOR-COMPILER X TYPE VALUES-PERMITTED-P)))
		(COND ((SUBTYPEP CANONIZED UNION *COMPILE-FILE-ENVIRONMENT*))
		      ((SUBTYPEP UNION CANONIZED *COMPILE-FILE-ENVIRONMENT*)
		       (SETQ UNION CANONIZED))
		      (T (SETQ UNION T)) )))
	    UNION))
	 (T ;; Permit forward type references in a DEFSUBST since the type may be known when it is expanded.
	    (unless (and (symbolp type)
			 ;; Could be NIL when invoked from
			 ;; (:METHOD CLOS:STANDARD-CLASS :MAKE-SLOT-DESCRIPTION)
			 ;; Should permit forward references there anyway.
			 (or (null *current-compiland*)
			     (compiland-subst-flag *current-compiland*)))
	      (WARN 'CANONICALIZE-TYPE-FOR-COMPILER ':IGNORABLE-MISTAKE
		  (IF (OR (SYMBOLP TYPE)
			  (AND (CONSP TYPE)
			       (SYMBOLP (FIRST TYPE))
			       (NEQ (FIRST TYPE) 'QUOTE) ))
		      "Undefined type specifier ~S in ~S"
		    "Invalid type specifier syntax ~S in ~S")
		  TYPE CONTEXT))
	    (IF (SYMBOLP TYPE)
		TYPE
	      'UNKNOWN)))))



(DEFPROP AP-1			LOCATIVE	FUNCTION-RESULT-TYPE) ; 10/30/89
(DEFPROP AP-2			LOCATIVE	FUNCTION-RESULT-TYPE)
(DEFPROP AP-3			LOCATIVE	FUNCTION-RESULT-TYPE)


))


#!C
; From file ansi.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ansi.É#É"

(COMMENT
(EXPORT
 '(COMMON-LISP:WITH-STANDARD-IO-SYNTAX COMMON-LISP:*READ-EVAL* COMMON-LISP:*PRINT-READABLY*
     COMMON-LISP:PRINT-UNREADABLE-OBJECT COMMON-LISP:MAP-INTO FS::LOGICAL-PATHNAME
     COMMON-LISP:TRANSLATE-LOGICAL-PATHNAME COMMON-LISP:LOGICAL-PATHNAME-TRANSLATIONS
     COMMON-LISP:LOAD-LOGICAL-PATHNAME-TRANSLATIONS COMMON-LISP:COMPILE-FILE-PATHNAME
     COMMON-LISP:WILD-PATHNAME-P COMMON-LISP:PATHNAME-MATCH-P COMMON-LISP:TRANSLATE-PATHNAME
     INTERACTIVE-STREAM-P COMMON-LISP:DECLAIM COMMON-LISP:DECLARATION-INFORMATION
     COMMON-LISP:PARSE-MACRO COMMON-LISP:ENCLOSE COMMON-LISP:FILE-STRING-LENGTH
     COMMON-LISP:DEFINE-COMPILER-MACRO COMMON-LISP:COMPILER-MACRO-FUNCTION)
 'SYS::CL))

(DEFMACRO COMMON-LISP:WITH-STANDARD-IO-SYNTAX (&BODY SYS::BODY)
  "Within the dynamic extent of the body, all reader and printer control
variables are bound to values that produce standard read/print
behavior.  Returns the values of the last body form."
  `(LET ((*PACKAGE* SYS::*COMMON-LISP-USER-PACKAGE*)
	 (*PRINT-ARRAY* T)
	 (*PRINT-BASE* 10)
	 (*PRINT-CASE* :UPCASE)
	 (*PRINT-CIRCLE* NIL)
	 (*PRINT-ESCAPE* T)
	 (*PRINT-GENSYM* T)
	 (*PRINT-LENGTH* NIL)
	 (*PRINT-LEVEL* NIL)
	 (*PRINT-PRETTY* NIL)
	 (*PRINT-RADIX* NIL)
	 (COMMON-LISP:*PRINT-READABLY* T)
	 (*READ-BASE* 10)
	 (*READ-DEFAULT-FLOAT-FORMAT* 'SINGLE-FLOAT)
	 (COMMON-LISP:*READ-EVAL* T)
	 (*READ-SUPPRESS* NIL)
	 (*READTABLE* SYS:COMMON-LISP-READTABLE)
	 (*PRINT-STRUCTURE* T)
	 (SYS::*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)
	 (SYS::*LISP-MODE* :COMMON-LISP))
     ,@SYS::BODY))

(DEFUN FS::LOGICAL-PATHNAME (PATHNAME)
  "Converts the argument to a logical pathname and returns it.
The argument can be a logical pathname, a logical pathname namestring containing
a host component, or a stream for which the PATHNAME function returns a logical
pathname.  For any other argument, a TYPE-ERROR is signalled."
  (LET ((PATHNAME (PATHNAME PATHNAME)))
    (UNLESS (TYPEP PATHNAME 'FS::LOGICAL-PATHNAME)
      (CLEH:ERROR 'CLEH:TYPE-ERROR :DATUM PATHNAME :EXPECTED-TYPE 'FS::LOGICAL-PATHNAME))
    PATHNAME))

(DEFUN COMMON-LISP:LOAD-LOGICAL-PATHNAME-TRANSLATIONS (SYS::HOST)
  "If a logical pathname host named HOST (a string) is already defined, return NIL.
Otherwise, search for a logical pathname host definition in an implementation
defined manner; on the Explorer, the file \"SYS:SITE;<host>.TRANSLATIONS\" is
loaded.  If no definition is found, signal an error.  If a definition is found,
install it and return T."
  (COND
    ((NET:PARSE-HOST SYS::HOST T T) NIL)
    (T (NET:MAKE-LOGICAL-PATHNAME-HOST SYS::HOST) T)))


))





#!C
; From file  External-system-symbols.LISP#> kernel; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL;  External-system-symbols.É#É"



(DEFCONSTANT *EXTERNAL-SYSTEM-SYMBOLS*
	     '(%%ARG-DESC-ANY-REST
		%%ARG-DESC-EVALED-REST
		%%ARG-DESC-FEF-BIND-HAIR
		%%ARG-DESC-FEF-LOCAL-BLOCK-LENGTH
		%%ARG-DESC-FEF-QUOTE-HAIR
		%%ARG-DESC-INTERPRETED 
		%%ARG-DESC-MAX-ARGS    
		%%ARG-DESC-MIN-ARGS    
		%%ARG-DESC-QUOTED-REST 
		%%ARRAY-DISPLACED-BIT
		%%ARRAY-FLAG-BIT
		%%ARRAY-INDEX-LENGTH-IF-SHORT
		%%ARRAY-LEADER-BIT
		%%ARRAY-LEADER-FUNCALL-AS-HASH-TABLE
		%%ARRAY-LEADER-LENGTH
		%%ARRAY-LONG-LENGTH-FLAG
		%%ARRAY-NAMED-STRUCTURE-FLAG
		%%ARRAY-NUMBER-DIMENSIONS
		%%ARRAY-PHYSICAL-BIT
		%%ARRAY-TYPE-AND-PHYSICAL-FIELD
		%%ARRAY-TYPE-FIELD
		%%BYTE-SPECIFIER-POSITION
		%%BYTE-SPECIFIER-SIZE
		%%CALL-INFO-MICROSTACK-PUSHED
		%%CALL-INFO-NUMBER-OF-ARGUMENTS
		%%CH-CHAR 
		%%CH-FONT 
		%%DATA-TYPE-AND-HEADER-FIELDS
		%%DOUBLE-FLOAT-EXPONENT
		%%DOUBLE-FLOAT-HIGH-MANTISSA
		%%DOUBLE-FLOAT-LOW-MANTISSA
		%%DOUBLE-FLOAT-PACKED-HIGH-TO-UNPACKED-HIGH-MANTISSA
		%%DOUBLE-FLOAT-PACKED-LOW-TO-UNPACKED-HIGH-MANTISSA
		%%DOUBLE-FLOAT-SIGN-BIT
		%%DOUBLE-FLOAT-UNPACKED-EXPONENT
		%%DOUBLE-FLOAT-UNPACKED-GUARD-BIT
		%%DOUBLE-FLOAT-UNPACKED-HIGH-MANTISSA
		%%DOUBLE-FLOAT-UNPACKED-HIGH-MANTISSA-AND-LEAD-BIT
		%%DOUBLE-FLOAT-UNPACKED-LEAD-BIT
		%%DOUBLE-FLOAT-UNPACKED-LOW-MANTISSA
		%%DOUBLE-FLOAT-UNPACKED-ROUND-BIT
		%%DOUBLE-FLOAT-UNPACKED-SIGN-BIT
		%%FIX-TO-DOUBLE-FLOAT-UNPACKED-HIGH-MANTISSA
		%%FIX-TO-DOUBLE-FLOAT-UNPACKED-LOW-MANTISSA
		%%HEADER-REST-FIELD
		%%HEADER-TYPE-FIELD
		%%KBD-CHAR
		%%KBD-CONTROL
		%%KBD-CONTROL-META 
		%%KBD-HYPER   
		%%KBD-KEYPAD
		%%KBD-META         
		%%KBD-MOUSE        
		%%KBD-MOUSE-BUTTON 
		%%KBD-MOUSE-N-CLICKS
		%%KBD-SUPER         
		%%M-FLAGS-CAR-NUM-MODE
		%%M-FLAGS-CAR-SYM-MODE
		%%M-FLAGS-CDR-NUM-MODE
		%%M-FLAGS-CDR-SYM-MODE
		%%M-FLAGS-DEFERRED-SEQUENCE-BREAK
		%%M-FLAGS-DONT-SWAP-IN
		%%M-FLAGS-INTERRUPT
		%%M-FLAGS-MAR-MODE
		%%M-FLAGS-METER-ENABLE
		%%M-FLAGS-PGF-WRITE
		%%M-FLAGS-QBBFL
		%%M-FLAGS-SCAVENGE
		%%M-FLAGS-STACK-GROUP-SWITCH
		%%M-FLAGS-TRANSPORT
		%%M-FLAGS-TRAP-ENABLE
		%%M-FLAGS-TRAP-ON-CALL
		%%METER-CONS-ENABLE
		%%METER-FUNCTION-ENTRY-EXIT-ENABLE
		%%METER-PAGE-FAULT-ENABLE
		%%METER-STACK-GROUP-SWITCH-ENABLE
		%%PHT1-AGE	;delete
		%%Q-ALL-BUT-CDR-CODE 
		%%Q-ALL-BUT-POINTER  
		%%Q-ALL-BUT-TYPED-POINTER 
		%%Q-BOXED-SIGN-BIT        
		%%Q-CDR-CODE              
		%%Q-DATA-TYPE             
		%%Q-HIGH-HALF             
		%%Q-LOW-HALF
		%%Q-POINTER	
		%%Q-POINTER-WITHIN-PAGE	
		%%Q-TYPED-POINTER	
		%%SELF-REF-INDEX
		%%SELF-REF-MAP-LEADER-FLAG
		%%SELF-REF-MONITOR-FLAG
		%%SELF-REF-RELOCATE-FLAG
		%%SELF-REF-WORD-INDEX
		%%SG-ST-CURRENT-STATE
		%%SG-ST-FOOTHOLD-EXECUTING
		%%SG-ST-IN-SWAPPED-STATE
		%%SG-ST-INST-DISP
		%%SG-ST-PROCESSING-ERROR
		%%SG-ST-PROCESSING-INTERRRUPT-REQUEST
		%%SG-ST-SAFE
		%%SG-ST-SWAP-SV-OF-SG-THAT-CALLS-ME
		%%SG-ST-SWAP-SV-ON-CALL-OUT
		%%SINGLE-TO-DOUBLE-FLOAT-UNPACKED-HIGH-MANTISSA
		%%SINGLE-TO-DOUBLE-FLOAT-UNPACKED-LOW-MANTISSA
		%%SPECPDL-BLOCK-START-FLAG
		%%SPECPDL-CLOSURE-BINDING
		%%US-MACRO-INSTRUCTION-RETURN
		%%US-PPBMIA
		%%US-PPBSPC
		%%US-RPC
		%%QMI-FULL-OPCODE
		%%QMI-DEST-OPCODE
		%%QMI-PUSH
		%QMI-PUSH
		%QMI-TEST
		%%QMI-REGISTER
		%QMI-REG-LEX
		%QMI-REG-CONST
		%QMI-REG-IVAR
		%QMI-REG-LOCAL
		%QMI-REG-ARG
		%QMI-REG-PDL
		%QMI-REG-IVAR
		%%QMI-OFFSET
		%%QMI-FEF-OFFSET
		%%QMI-INST-ADR
		%%QMI-MISC-OP
		%%QMI-AUX-OP
		%%QMI-External-Module-Number
		%%QMI-Module-Op
		%%QMI-BR-OFFSET
		%%QMI-CALL-DEST
		%%QMI-MOD-DEST
		%QMI-CALLDEST-INDS
		%QMI-CALLDEST-PUSH
		%QMI-CALLDEST-RETURN
		%QMI-CALLDEST-TAIL-REC
		%%QMI-CALL-NUMARGS
		%%QMI-LEX-LEVEL
		%QMI-LEX-PARENT-A
		%QMI-LEX-PARENT-B
		%%QMI-LEX-OFFSET
		%%QMI-IVAR-MAPPED
		%%QMI-IVAR-INDEX
		%24-BIT-DIFFERENCE
		%24-BIT-PLUS
		%24-BIT-TIMES
		%ACTIVATE-OPEN-CALL-BLOCK	
		%ADD-INTERRUPT
		%ADD-PAGE-DEVICE
		%ADDRESS-SPACE-MAP-BYTE-SIZE
		%ADDRESS-SPACE-QUANTUM-SIZE
		%ALLOCATE-AND-INITIALIZE      
		%ALLOCATE-AND-INITIALIZE-ARRAY
		%ALLOCATE-AND-INITIALIZE-INSTANCE
		%ALLOCATE-AND-INITIALIZE-SYMBOL ; DNG 11/6/89
		%AREA-NUMBER
		%ARG-DESC-EVALED-REST  
		%ARG-DESC-FEF-BIND-HAIR     
		%ARG-DESC-FEF-QUOTE-HAIR    
		%ARG-DESC-INTERPRETED       
		%ARG-DESC-QUOTED-REST
		%ARRAY-LEADER-LENGTH
		%ARRAY-MAX-SHORT-INDEX-LENGTH
		%ASSURE-PDL-ROOM			
		%BIND
		%BINDING-INSTANCES
		%BLT
		%BLT-FROM-PHYSICAL
		%BLT-TO-PHYSICAL
		%BLT-TYPED
		%BUFFER-CHAR-MAP		;kt 8-5-88
		%CALL
		%CALL-STATE-LENGTH
		%CATCH-BLOCK-CATCH-TAG
		%CATCH-BLOCK-SAVED-CATCH-POINTER
		%CHANGE-PAGE-STATUS
		%CLASS-DESCRIPTION		;RJF 2/03/88
		%COMPUTE-PAGE-HASH
                %CRASH
		%CREATE-PHYSICAL-PAGE 
		%CURRENT-STACK-GROUP-CALLING-ARGS-NUMBER
		%CURRENT-STACK-GROUP-CALLING-ARGS-POINTER
		%CURRENT-STACK-GROUP-STATE
		%DATA-TYPE
		%DELETE-PHT-ENTRY 
		%DELETE-PHYSICAL-PAGE
		%DISABLE-NUPI-LOCKING
		%DISPATCH-METHOD	
		%DISK-BLOCKS-PER-CYLINDER
		%DISK-BLOCKS-PER-TRACK
		%DISK-PAGE-MAPPING-TABLE-ENTRY	;delete
		%DISK-RESTORE
		%DISK-RUN-LIGHT
		%DISK-SWITCHES
		%DIVIDE-DOUBLE
		%DRAW-CHARACTER
		%DRAW-CHAR			
		%DRAW-FILLED-RASTER-LINE		
		%DRAW-FILLED-TRIANGLE		
		%DRAW-LINE
		%DRAW-RECTANGLE
		%DRAW-SHADED-RASTER-LINE
		%DRAW-SHADED-TRIANGLE
		%DRAW-STRING
		%ENABLE-NUPI-LOCKING 
		%ERROR-HANDLER-STACK-GROUP
		%EXTERNAL-VALUE-CELL
		%FEF-HEADER-LENGTH
		%FINDCORE
		%FIND-STRUCTURE-HEADER 
		%FIND-STRUCTURE-LEADER 
		%FIXNUM-MICROSECOND-TIME
		%FLOAT-DOUBLE
		%FLUSH-EXTRA-PDL
		%FUNCTION-INSIDE-SELF
		%GC-CONS-WORK 
		%GC-FLIP
		%GC-FLIP-READY
		%GC-FREE-REGION
		%GC-GENERATION-NUMBER
		%GC-SCAV-RESET
		%GC-SCAVENGE 
		%GET-SELF-MAPPING-TABLE
		%GETLONG			;kt 8-5-88
		%GETWORD-16B			;kt 8-5-88
		%HALT
		%HEADER-TYPE-ARRAY-LEADER
		%HEADER-TYPE-BIGNUM
		%HEADER-TYPE-COMPLEX
		%HEADER-TYPE-DOUBLE-FLOAT
		%HEADER-TYPE-ERROR
		%HEADER-TYPE-FLONUM
		%HEADER-TYPE-RATIONAL
		%IMPORT-OBJECT	
		%INHIBIT-READ-ONLY
		%INITIAL-FEF
		%INITIAL-STACK-GROUP
		%INITIALLY-DISABLE-TRAPPING
		%INSTANCE-DESCRIPTOR-ALL-INSTANCE-VARIABLES
		%INSTANCE-DESCRIPTOR-BINDINGS
		%INSTANCE-DESCRIPTOR-DEPENDS-ON-ALL
		%INSTANCE-DESCRIPTOR-FUNCTION
		%INSTANCE-DESCRIPTOR-HEADER
		%INSTANCE-DESCRIPTOR-IGNORE
		%INSTANCE-DESCRIPTOR-MAPPING-TABLE-ALIST
		%INSTANCE-DESCRIPTOR-RESERVED
		%INSTANCE-DESCRIPTOR-SIZE
		%INSTANCE-DESCRIPTOR-TYPENAME
		%INSTANCE-LOC
		%INSTANCE-REF
		%INTERNAL-VALUE-CELL
		%IO
                %IO-SPACE-READ  
                %IO-SPACE-WRITE 
		%LOAD-MEMORY-MAP
		%LOGDPB
		%LOGICAL-PAGE-DEVICE-INFORMATION-BLOCK
		%LOGLDB
		%MAKE-EXPLICIT-STACK-LIST
		%MAKE-EXPLICIT-STACK-LIST*
		%MAKE-LIST
		%MAKE-LIST*			;8/5/88 ab
		%MAKE-POINTER 
		%MAKE-POINTER-OFFSET
		%MAKE-REGION
		%MAKE-STACK-LIST
		%MAR-HIGH
		%MAR-LOW
		%METER-BUFFER-POINTER
		%METER-CONS-EVENT
		%METER-DISK-ADDRESS
		%METER-DISK-COUNT
		%METER-FUNCTION-ENTRY-EVENT
		%METER-FUNCTION-EXIT-EVENT
		%METER-FUNCTION-UNWIND-EVENT
		%METER-GLOBAL-ENABLE
		%METER-MICRO-ENABLES
		%METER-PAGE-IN-EVENT
		%METER-PAGE-OUT-EVENT
		%METER-STACK-GROUP-SWITCH-EVENT
		%MICROCODE-VERSION-NUMBER
		%MICROSECOND-TIME
		%MULTIPLE-VALUE-LIST-RETURN
		%MULTIPLY-FRACTIONS
		%NORMAL-RETURN
		%NUBUS-PHYSICAL-ADDRESS
		%NUBUS-READ
		%NUBUS-READ-16B
		%NUBUS-READ-8B
		%NUBUS-READ-8B-CAREFUL
		%NUBUS-WRITE
		%NUBUS-WRITE-16B
		%NUBUS-WRITE-8B
		%ONLY-ONE-RESULT-NEEDED
		%NUMBER-OF-MICRO-ENTRIES
		%OPEN-MOUSE-CURSOR
		%OPEN-CALL-BLOCK			
		%P-CDR-CODE
		%P-CDR-CODE-OFFSET
		%P-CONTENTS-AS-LOCATIVE
		%P-CONTENTS-AS-LOCATIVE-OFFSET
		%P-CONTENTS-OFFSET
		%P-CONTENTS-SAFE-P
		%P-CONTENTS-SAFE-P-OFFSET
		%P-DATA-TYPE
		%P-DATA-TYPE-OFFSET
		%P-DEPOSIT-FIELD
		%P-DEPOSIT-FIELD-OFFSET
		%P-DPB
		%P-DPB-OFFSET
		%P-LDB
		%P-LDB-OFFSET
		%P-MASK-FIELD
		%P-MASK-FIELD-OFFSET
		%P-POINTER
		%P-POINTER-OFFSET
		%P-POINTERP
		%P-POINTERP-OFFSET
		%P-SAFE-CONTENTS-OFFSET
		%P-STORE-CDR-CODE
		%P-STORE-CDR-CODE-OFFSET
		%P-STORE-CONTENTS
		%P-STORE-CONTENTS-OFFSET
		%P-STORE-DATA-TYPE
		%P-STORE-DATA-TYPE-OFFSET
		%P-STORE-POINTER
		%P-STORE-POINTER-OFFSET
		%P-STORE-TAG-AND-POINTER
		%PAGE-CONS-ALARM
		%PAGE-IN
		%PAGE-STATUS
		%PAGE-TRACE
	       %PHYS-LOGDPB
	       %PHYS-LOGLDB
	       %PHYSICAL-ADDRESS
	       %POINTER
	       %POINTER-DIFFERENCE
	       %POINTER-PLUS
	       %POINTER-TIMES
	       %POINTER-TYPE-P
	       %POINTERP
	       %POP				
	       %PUSH
	       %PUTLONG				;kt 8-5-88
	       %PUTWORD-16B			;kt 8-5-88
	       %RATIO-CONS
	       %RECORD-EVENT
	       %REGION-CONS-ALARM
	       %REGION-NUMBER
	       %REMAINDER-DOUBLE
	       %RETURN-ALL-VALUES-WITH-COUNT-ON-STACK
	       %SCHEDULER-STACK-GROUP
	       %SCROLL			
               %SCRUB			
	       %SET-MOUSE-SCREEN
	       %SET-SELF-MAPPING-TABLE 
	       %SPREAD
	       %STACK-FRAME-POINTER
	       %STORE-CONDITIONAL
	       %STORE-KEY-WORD-ARGS	
	       %STRING-EQUAL
	       %STRING-SEARCH-CHAR
	       %STRING-WIDTH
	       %STRUCTURE-BOXED-SIZE
	       %STRUCTURE-TOTAL-SIZE
	       %SUM-ARRAY			;ab 8/19/88
	       %SXHASH-STRING
	       %SYS-COM-AREA-ORIGIN-PNTR
	       %SYS-COM-BAND-FORMAT
	       %SYS-COM-CHAOS-FREE-LIST
	       %SYS-COM-CHAOS-RECEIVE-LIST
	       %SYS-COM-CHAOS-TRANSMIT-LIST
	       %SYS-COM-DEBUGGER-DATA-1
	       %SYS-COM-DEBUGGER-DATA-2
	       %SYS-COM-DEBUGGER-KEEP-ALIVE
	       %SYS-COM-DEBUGGER-REQUESTS
	       %SYS-COM-DESCRIPTOR-SPACE-FREE-POINTER
	       %SYS-COM-DESIRED-MICROCODE-VERSION
	       %SYS-COM-DEVICE-INTERRUPT-TABLE
	       %SYS-COM-ETHER-FREE-LIST
	       %SYS-COM-ETHER-RECEIVE-LIST
	       %SYS-COM-ETHER-TRANSMIT-LIST
	       %SYS-COM-FREE-AREA#-LIST
	       %SYS-COM-FREE-REGION#-LIST
	       %SYS-COM-GC-GENERATION-NUMBER
	       %SYS-COM-HIGHEST-VIRTUAL-ADDRESS
	       %SYS-COM-MAJOR-VERSION
	       %SYS-COM-MEMORY-SIZE
	       %SYS-COM-OBARRAY-PNTR
	       %SYS-COM-PAGE-DEVICE-TABLE
	       %SYS-COM-PAGE-TABLE-PNTR
	       %SYS-COM-PAGE-TABLE-SIZE
	       %SYS-COM-POINTER-WIDTH
	       %SYS-COM-PROCESSOR-SLOT
	       %SYS-COM-SYSTEM-NUPI-DESCRIPTOR
	       %SYS-COM-TEMPORARY
	       %SYS-COM-VALID-SIZE
	       %SYS-COM-WIRED-SIZE
	       %TEST&SET-68K
	       %TRAP-MICRO-PC
	       %USING-BINDING-INSTANCES 
	       %WRITE-INTERNAL-PROCESSOR-MEMORIES
               *ADAPTIVE-TRAINING-ENABLED*
	       *BATCH-MODE-P*
	       *BOOLE
	       *BREAK-BINDINGS*
	       *DEBUG-INFO-LOCAL-DECLARATION-TYPES*
	       *DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*
	       *DEFAULT-BIT-ARRAY-PRINTER*
	       *DEFAULT-DISK-UNIT*
	       *DEFAULT-PRINTER*
	       *DONT-RECOMPILE-FLAVORS*
	       *EVAL
	       *FILE-TRANSFORMATION-FUNCTION*
	       *GC-CONSOLE-DELAY-INTERVAL*
	       *GC-MAX-INCREMENTAL-GENERATION* 
	       *GC-NOTIFICATIONS*
               *GC-REPORT-STREAM*
	       *GENSYM-COUNTER*		; DNG 5/1/89
	       *LOADED-BAND*
	       *load-sib*			;ab 6/8/88 (and next 8)
	       *load-disk*
	       *load-nvram*
	       *load-keyboard*
	       *load-mouse*
	       *load-rtc*
	       *load-sound*
	       *load-nubus*
	       *load-enet*
	       *LOGAND
	       *LOGIOR
	       *LOGXOR
	       *FILE-TRANSFORMATION-FUNCTION*
 	       *FLAVOR-COMPILATIONS*
	       *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*
	       *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE*
	       *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*
	       *MICROCODE-NAME-ALIST*
               *MICROCODE-TYPE-LIST*
	       *QUERY-TYPE*
	       *READ-ACCEPT-EXTENSIONS*
	       *REDO-ALL*
	       *SILENT-P*
	       *SYSTEM-BEING-DEFINED*
	       *SYSTEM-BEING-MADE*
	       *SYSTEM-NAME*		; DNG 11/6/89
	       *TGC-TRAINING-ENABLED*
	       *TOP-LEVEL-TRANSFORMATIONS*
	       A-MEMORY-ARRAY-SYMBOLS
	       A-MEMORY-COUNTER-BLOCK-NAMES
	       A-MEMORY-LOCATION-NAMES
	       A-MEMORY-VIRTUAL-ADDRESS
	       ACTIVE-PROCESSES
	       ADDIN-P				;ab 2/19/88
	       ADDRESS-SPACE-MAP
	       ADVISE-1
	       ADVISED-FUNCTIONS
	       ALL-PROCESSES
	       AMEM-EVCP-VECTOR
	       AREA-MAXIMUM-SIZE
	       AREA-REGION-BITS
	       AREA-REGION-LIST
	       AREA-REGION-SIZE
	       AREA-TEMPORARY-P
	       ARGS-DESC
	       ARRAY-DIM-MULT
	       ARRAY-DIMENSION-SHIFT
	       ARRAY-DISPLACED-BIT
	       ARRAY-FIELDS
	       ARRAY-LEADER-BIT
	       ARRAY-LEADER-FIELDS
	       ARRAY-LONG-LENGTH-FLAG
	       ARRAY-MISCS
	       ARRAY-NAMED-STRUCTURE-FLAG
	       ARRAY-REGISTER		; declaration ignored for brand S compatibility
	       ARRAY-REGISTER-1D	; declaration ignored for brand S compatibility
	       ARRAY-TYPE-FROM-ELEMENT-TYPE
	       ARRAY-TYPE-SHIFT
	       ASSOC-EQL
	       ASSOC-EQUALP
	       BACKGROUND-CONS-AREA
	       BEFORE-COLD-INITIALIZATION-LIST
	       BIDIRECTIONAL-STREAM
	       BIGNUM-TO-ARRAY
	       BUFFERED-CHARACTER-STREAM
	       BUFFERED-INPUT-CHARACTER-STREAM
	       BUFFERED-INPUT-STREAM
	       BUFFERED-OUTPUT-CHARACTER-STREAM
	       BUFFERED-OUTPUT-STREAM
	       BUFFERED-STREAM
	       CADR-TYPE-CODE
	       CARCDR
	       CELL-LOCATION-IN-STACK-GROUP
	       CHANGE-INDIRECT-ARRAY
	       CHANGE-SWAP-SPACE-ALLOCATION
	       CLASSP
	       CLEAN-UP-STATIC-AREA
	       CLOCK-FUNCTION-LIST
	       CODE-MOUSE-CHAR
	       COERCE-TO-ARRAY-OPTIMIZED
	       COERCE-TO-CHARACTER
	       COERCE-TO-DOUBLE-FLOAT
	       COERCE-TO-FLOAT
	       COERCE-TO-LIST
	       COERCE-TO-SINGLE-FLOAT
	       COERCE-TO-SMALL-FLOAT
  	       COLD-INITIALIZATION-LIST
	       COLD-LOAD-STREAM
	       COMMON-LISP-AR-1
	       COMMON-LISP-AR-1-FORCE
	       COMMON-LISP-AR-2
	       COMMON-LISP-AR-3
	       COMMON-LISP-AREF
	       COMMON-LISP-ELT
	       COMMON-LISP-LISTP
	       COMMON-LISP-READTABLE
	       COMPARE-BAND
	       COMPILE-IF
	       COMPILE-LOAD-IF
	       COMPUTE-LISPM-ARRAY-TYPE
	       CONSP-OR-POP
 	       CONTROL-TABLES
	       CONVERT-TO-DOUBLE-FLOAT-UNPACKED-FIELDS
	       COPY-OBJECT-TREE
	       CURRENT-BAND
	       CURRENT-MICROLOAD
	       CURRENTLY-PREPARED-SHEET
	       DBIS-PLIST
	       DEBUG-WARM-BOOTED-PROCESS
	       DECLARED-DEFINITION
	       DECODE-KEYWORD-ARGLIST
	       DEFINE-DEFSYSTEM-SPECIAL-VARIABLE
	       DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE
	       DEFINE-SIMPLE-TRANSFORMATION
	       DEFSTRUCT-DEFINE-TYPE
	       DEFUN-COMPATIBILITY
	       DELETE-BINDING-FROM-CLOSURE
	       DELETE-LIST-EQ
	       DEP-COMPILE-IF
	       DEP-COMPILE-LOAD-IF
 	       DEVICE-DESCRIPTOR-AREA
	       DISJOINT-TYPEP
	       DISK-PAGE-MAP-AREA
	       DISK-READ
	       DISK-READ-COMPARE
	       DISK-WRITE
	       DISPLACED
	       DOUBLE-FLOAT-CONSTANTS
	       DOUBLE-FLOAT-FIELDS
	       DOUBLE-FLOAT-MANTISSA-PLUS-GUARD-PLUS-ROUND-LENGTH
	       DOUBLE-FLOAT-MAXIMUM-UNPACKED-EXPONENT
	       DOUBLE-FLOAT-MINIMUM-UNPACKED-EXPONENT
	       DOUBLE-FLOAT-PACKED-TO-UNPACKED-FIELDS
	       DOUBLE-FLOAT-UNPACKED-FIELDS
	       DOUBLE-FLOATP 
	       DOWNWARD-FUNARG
	       DOWNWARD-FUNCTION
	       DTP-ARRAY					
	       DTP-ARRAY-HEADER			    
	       DTP-ARRAY-POINTER		;obsolete - now dtp-array				
	       DTP-BODY-FORWARD			       
	       DTP-CHARACTER				       
	       DTP-CLOSURE
	       DTP-EXTENDED-NUMBER			       
	       DTP-EXTERNAL-VALUE-CELL-POINTER		       
	       DTP-FEF-HEADER				       
	       DTP-FEF-POINTER			;obsolete - now dtp-function
	       DTP-FIX					       
	       DTP-FREE					
	       DTP-FUNCTION					
	       DTP-GC-FORWARD
	       DTP-HEADER					
	       DTP-HEADER-FORWARD			       
	       DTP-INSTANCE				       
	       DTP-INSTANCE-HEADER				
	       DTP-LEXICAL-CLOSURE				
	       DTP-LIST					
	       DTP-LOCATIVE				       
	       DTP-NULL				       
	       DTP-ONE-Q-FORWARD			       
	       DTP-ONES-TRAP
	       DTP-SELF-REF-POINTER			       
	       DTP-SHORT-FLOAT					
	       DTP-SINGLE-FLOAT				
	       DTP-STACK-CLOSURE		;obsolete - now dtp-lexical-closure
	       DTP-STACK-GROUP				       
	       DTP-STACK-LIST				       
	       DTP-SYMBOL				       
	       DTP-SYMBOL-HEADER				
	       DTP-TRAP					
	       DTP-U-ENTRY
	       DUMP-MEMORY			;ab 2/19/88
	       DUMP-PHYSICAL			;ab 2/19/88
	       DUMP-OBJECTS-IN-REGION
	       DUMP-WARNINGS
	       DWIMIFY-ARG-PACKAGE
	       DWIMIFY-PACKAGE
	       DWIMIFY-PACKAGE-0
	       EAS-ON				;jho 4/22/88
	       EDIT-DISK-LABEL
	       ENCAPSULATE
	       ENCAPSULATION-BODY
	       ENCAPSULATION-STANDARD-ORDER
	       EVAL-ABORT-TRIVIAL-ERRORS
	       EVAL1
	       EXP2-P				;ab 2/19/88
	       EXPONENT-CONVERSIONS
	       EXTRA-PDL-AREA 
	       EXTRACT-DEBUG-INFO-STRUCT-FROM-FEF
	       EXTRACT-DECLARATIONS
	       FASL-CONSTANTS-AREA
	       FASL-RECORD-FILE-MACROS-EXPANDED
	       FASL-TABLE-AREA
	       FASL-TEMP-AREA
	       FASLOAD-COMBINED
	       FAT-STRING-CHAR-P
	       FDEFINE-FILE-PATHNAME
	       FDEFINITION-SAFE
	       FEF-ADL-LENGTH
	       FEF-ADL-ORIGIN
	       FEF-BIT-MAP
	       FEF-BIT-MAP-P
	       FEF-FAST-ARGUMENT-OPTION-P
	       FEF-FAST-ARGUMENT-OPTION-WORD
	       FEF-HEADER-FIELDS
	       FEF-INITIAL-PC
	       FEF-INSTRUCTION
	       FEF-INSTRUCTION-LENGTH
 	       FEF-LENGTH
	       FEF-LIMIT-PC
	       FEF-NAME
	       FEF-NO-ADL-P
	       FEF-NUMBER-OF-LOCALS
	       FEF-SPECIALS-BOUND-P
	       FILE-IN-COLD-LOAD
	       FILE-LOCAL-DECLARATIONS
	       FILE-LOCAL-DECLARATIONS-DEF-ALIST
 	       FILE-OPERATION-WITH-WARNINGS
	       FILE-STREAM-MIXIN
	       FIND-DISK-PARTITION
	       FIND-DISK-PARTITION-FOR-READ
	       FIND-DISK-PARTITION-FOR-WRITE
	       FIND-READTABLE-NAMED
 	       FIX-TO-DOUBLE-FLOAT-EXPONENT
	       FLAVOR-ALL-ALLOWED-INIT-KEYWORDS
	       FLAVOR-ALL-INSTANCE-VARIABLES
	       FLAVOR-VAR-SELF-REF-INDEX
	       FLOAT-EXPONENT
	       FLOAT-FRACTION
	       FUNCALL-WITH-MAPPING-TABLE-INTERNAL
 	       FUNCTION-PARENT
	       FUNCTION-SPEC-GET
	       FUNCTION-SPEC-HANDLER
	       FUNCTION-SPEC-LESSP
	       FUNCTION-SPEC-P ; DNG 3/16/89 - used in Inspector, Zmacs, and code walker
	       FUNCTION-SPEC-PUSH-PROPERTY
	       FUNCTION-SPEC-PUTPROP
	       FUNCTION-START-SYMBOLS
	       GC-EXTERNAL				;;jho 4/22/88
	       GC-REPORT-STREAM
	       GET-ALL-SOURCE-FILE-NAMES
	       GET-DEBUG-INFO-FIELD
	       GET-DEBUG-INFO-STRUCT
	       GET-DISK-FIXNUM
	       GET-DISK-RQB
 	       GET-DISK-STRING
	       GET-FILE-LOADED-ID
	       GET-FLAVOR 
	       GET-FROM-FRAME-LIST ; DNG 4/27/89
 	       GET-LEXICAL-VALUE-CELL
	       GET-LOCATION
	       GET-LOCATION-OR-NIL
	       GET-MACRO-ARG-DESC-POINTER
 	       GET-SOURCE-FILE-NAME
	       GET-SYSTEM-VERSION
	       HARDWARE-MEMORY-SIZES
	       HEADER-FIELDS
	       HOST-ALIST
	       INHIBIT-DISPLACING-FLAG
	       INHIBIT-GC-FLIPS 
	       INHIBIT-IDLE-SCAVENGING-FLAG
	       INHIBIT-SCAVENGING-FLAG
 	       INIT-LIST-AREA
	       INITIAL-COMMON-LISP-READTABLE
	       INITIAL-PROCESS
	       INITIAL-READTABLE
	       INITIALIZATION-KEYWORDS
	       INPUT-FILE-STREAM-MIXIN
	       INPUT-POINTER-REMEMBERING-MIXIN
	       INPUT-STREAM
	       INSERT-BINDING-IN-CLOSURE
	       INSTANCE-DESCRIPTOR-OFFSETS
	       INSTANCE-FLAVOR
	       INTERNAL-CHAR-EQUAL
	       INTERNAL-FLOAT
	       INTERNAL-GET-3
	       INTERNAL-MAKE-SIMPLE-VECTOR
	       INVALID-FUNCTION
	       IO-SPACE-VIRTUAL-ADDRESS
	       IO-STREAM-P ; used by STREAMP, referenced by inspector 
	       KBD-CONVERT-TO-SOFTWARE-CHAR
	       KBD-GET-HARDWARE-CHAR
	       KBD-HARDWARE-CHAR-AVAILABLE
	       LAMBDA-EXP-ARGS-AND-BODY
	       LAMBDA-MACRO-CALL-P
	       LAMBDA-MACRO-EXPAND
	       LAMBDA-TYPE-CODE
	       LENGTH-GREATERP
	       LENGTH-OF-ATOM-HEAD
	       LENGTH-OF-FASL-TABLE
	       LEXICAL-ENVIRONMENT
	       LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL
	       LINE-OUTPUT-STREAM-MIXIN
	       LINEAR-BIND-PDL-AREA
	       LINEAR-PDL-AREA
	       LISP-CRASH-LIST
	       LISP-ERROR-HANDLER
	       LISP-REINITIALIZE
	       LISP-TOP-LEVEL
	       LISP-TOP-LEVEL1
	       LOAD-IF
	       LOCAL-BINARY-FILE-TYPE
	       LOCF-METHOD
	       LOGIN-HISTORY
	       LOOP-NAMED-VARIABLE
	       LOOP-TASSOC
	       LOOP-TEQUAL
	       LOOP-TMEMBER
	       M-EQ
	       M-FLAGS-FIELDS
	       M-MEMORY-LOCATION-NAMES
	       MAKE-DEBUG-INFO-STRUCT
	       MACROS-EXPANDED
	       MAKE-FLAVOR-INSTANCE ; DNG 3/18/89
	       MAKE-OBSOLETE
	       MAKE-PARALLEL-STREAM
	       MAKE-PROCESS-QUEUE
	       MAKE-SERIAL-STREAM
	       MAYBE-PRINT-OBJECT-WARNINGS-HEADER
	       MEASURED-SIZE-OF-PARTITION
 	       MEMBER-EQL
	       MEMBER-EQUALP
	       METER-ENABLES
	       METER-EVENTS
	       MICRO-CODE-ENTRY-AREA
	       MICRO-CODE-ENTRY-DEBUG-INFO-AREA
	       MICRO-STACK-FIELDS
	       MICROCODE-TYPE-CODE
	       MISMATCH*
	       MOUSE-BUTTONS-BUFFER
	       MOUSE-CURSOR-PATTERN
	       MOUSE-WAKEUP
	       MOUSE-X-SCALE-ARRAY
	       MOUSE-Y-SCALE-ARRAY
	       MX-BOOT-STATUS			;ab 02/19/88
	       MX-P				;ab 02/19/88
	       NON-FATAL-ERROR			;DNG 3/16/89
	       NR-SYM
	       NULL-STREAM
	       NUMBER-CONS-AREA
	       NUMERIC-ARG-DESC-FIELDS
	       OBJECT-OPERATION-WITH-WARNINGS
	       OBT-TAILS
	       ONCE-ONLY-INITIALIZATION-LIST
	       OUTPUT-FILE-STREAM-MIXIN
	       OUTPUT-POINTER-REMEMBERING-MIXIN
	       OUTPUT-STREAM			
	       P-N-STRING
	       PAGE-GC-BITS
	       PAGE-HASH-TABLE-FIELDS
	       PAGE-IN-AREA
	       PAGE-IN-ARRAY
	       PAGE-IN-PIXEL-ARRAY
 	       PAGE-IN-REGION
	       PAGE-IN-STRUCTURE
	       PAGE-IN-WORDS
	       PAGE-OUT-AREA
	       PAGE-OUT-ARRAY
	       PAGE-OUT-PIXEL-ARRAY
	       PAGE-OUT-REGION
	       PAGE-OUT-STRUCTURE
	       PAGE-OUT-WORDS
	       PAGE-SIZE
	       PAGE-TABLE-AREA
	       PARSE-FERROR
	       PARTITION-COMMENT
	       PATCH-LOADED-P
 	       PDL-AREA
	       PDL-ARRAY-INDEX
	       PDL-BUFFER-INDEX
	       PDL-WORD
	       PHYSICAL-PAGE-DATA
	       PKG-AREA
	       PKG-SHORTEST-NAME
	       ;;ab 8/6/87.  Add Prolog MISCOP names.
	       PL-TRAIL1
	       PL-BIND-VAR-TO-VAR
	       PL-BIND-VAR-TO-TERM
	       PL-VARP
	       PL-LISTP
	       PL-STRUCTP
	       PL-ATOMP
	       PL-ATOMICP
	       PL-INITIALIZE
	       PL-INITIALIZE1
	       PL-DEREFERENCE
	       PL-RESOLVE
	       PL-STACK-OVERFLOW-SAVECP
	       PLL-FAIL1
	       PL-UNIFY1
	       ;;ab
	       POP-M-FROM-UNDER-N
	       PREMATURE-WARNINGS
	       PREMATURE-WARNINGS-MARKER
	       PRINT-DISK-ERROR-LOG
	       PRINT-LIST
	       PRINT-NOT-READABLE
	       PRINT-OBJECT
	       PRINTING-RANDOM-OBJECT
	       PRINT-READABLY
	       PRINT-READABLY-MIXIN
	       PROCESS
	       PROCESS-DEQUEUE
	       PROCESS-ENQUEUE
	       PROCESS-QUEUE-LOCKER
	       PROCESSOR-TYPE	
	       PROPERTY-LIST-AREA
	       PROPERTY-LIST-MIXIN
	       PUT-DEBUG-INFO-FIELD
	       PUT-DISK-FIXNUM
	       PUT-DISK-STRING
	       Q-CDR-CODES
	       Q-FIELDS
	       Q-GCV-MVP-BITS
	       Q-HEADER-TYPES
	       Q-REGION-BITS
	       QUOTE-EVAL-AT-LOAD-TIME
	       RANDOM-CREATE-ARRAY
	       RANDOM-IN-RANGE
	       RANDOM-INITIALIZE
 	       RASSOC-EQL
	       RASSOC-EQUALP
	       RATIOP
	       RDTBL-NAMES
	       READ-AREA
	       READ-RECURSIVE
	       RECEIVE-BAND
	       RECORD-AND-PRINT-WARNING
 	       RECORD-MACROS-EXPANDED
	       RECORD-SOURCE-FILE-NAME
	       RECORD-WARNING
 	       REG-PDL-LEADER-QS
	       REG-PDL-SG-HEAD-POINTER
	       REGION-BITS
	       REGION-FREE-POINTER
	       REGION-GC-POINTER
	       REGION-LENGTH
	       REGION-LIST-THREAD
	       REGION-ORIGIN
	       REGULAR-PDL-SG
	       RENAME-WITHIN-NEW-DEFINITION-MAYBE
	       RESET-PROCESS-QUEUE
	       RESET-TEMPORARY-AREA
	       RESIDENT-SYMBOL-AREA
	       RESOURCE-IN-USE-P
	       RESOURCE-N-OBJECTS
	       RESOURCE-OBJECT
	       RESOURCE-PARAMETERS
	       RESOURCE-PARAMETIZER
	       RETURN-DISK-RQB
	       RP-ARGUMENT-POINTER
	       RP-ARGUMENT-OFFSET
 	       RP-BINDING-BLOCK-PUSHED
	       RP-CALL-INFO-WORD
	       RP-DESTINATION
	       RP-EXIT-PC
	       RP-ENV-PTR-POINTS-HERE
	       RP-FEF-WORD
	       RP-FUNCTION-WORD
	       RP-LEXPR-FUNCALL-FLAG
	       RP-LOCAL-POINTER
	       RP-LOCAL-OFFSET
	       RP-LOCATION-COUNTER-OFFSET
	       RP-MICRO-STACK-PUSHED
	       RP-MICRO-STACK-SAVED
	       RP-NUMBER-ARGS-SUPPLIED
	       RP-NUMBER-OF-ARGUMENTS
	       RP-NUMBER-OF-RESULTS
	       RP-RETURN-TYPE
	       RP-SAVED-DESTINATION
	       RP-SELF-MAP-TABLE-PROVIDED
	       RP-TRAP-ON-EXIT
	       RQB-8-BIT-BUFFER
	       RQB-BUFFER
	       RQB-NPAGES
	       SB-ON
	       SCAVENGER-WS-ENABLE
	       SCHEDULER-STACK-GROUP
	       SCHEME-ON-P ; defined in "SYS:PUBLIC.SCHEME;MODE" but used in "COMPILER;FILE".
 	       SCRATCH-PAD-INIT-AREA
	       SELF-BINDING-INSTANCES
 	       SELF-FLAVOR-DECLARATION
 	       SELF-MAPPING-TABLE
	       SELF-REF
	       SELF-REF-POINTER-FIELDS
	       SET-%INSTANCE-REF
	       SET-ALL-SWAP-RECOMMENDATIONS
	       SET-AR-1
	       SET-AR-1-FORCE
	       SET-AR-2
	       SET-AR-3
	       SET-AREF
	       SET-ARRAY-LEADER
	       SET-CURRENT-BAND
	       SET-FILE-LOADED-ID
	       SET-MEMORY-SIZE
	       SET-PROCESS-WAIT
	       SET-SCAVENGER-WS
	       SET-SWAP-RECOMMENDATIONS-OF-AREA
	       SET-SYSTEM-SOURCE-FILE
	       SET-SYSTEM-STATUS
	       SETCAR
	       SETCDR
	       SETELT
	       SG-AC-1
	       SG-AC-2
	       SG-AC-3
	       SG-AC-4
	       SG-AC-A
	       SG-AC-B
	       SG-AC-C
	       SG-AC-D
	       SG-AC-E
	       SG-AC-F
	       SG-AC-G
	       SG-AC-H
	       SG-AC-I
	       SG-AC-J
	       SG-AC-K
	       SG-AC-L
	       SG-AC-Q
	       SG-AC-R
	       SG-AC-S
	       SG-AC-T
	       SG-AC-ZR
	       SG-CALLING-ARGS-NUMBER
	       SG-CALLING-ARGS-POINTER
	       SG-CATCH-POINTER
	       SG-CURRENT-STATE
	       SG-DEBUG-DISPATCH
	       SG-FLAGS-CAR-NUM-MODE
	       SG-FLAGS-CAR-SYM-MODE
	       SG-FLAGS-CDR-NUM-MODE
	       SG-FLAGS-CDR-SYM-MODE
	       SG-FLAGS-DONT-SWAP-IN
	       SG-FLAGS-MAR-MODE
	       SG-FLAGS-METER-ENABLE
	       SG-FLAGS-PGF-WRITE
	       SG-FLAGS-QBBFL
	       SG-FLAGS-TRAP-ENABLE
	       SG-FLAGS-TRAP-ON-CALL
	       SG-FOOTHOLD-DATA
	       SG-FOOTHOLD-EXECUTING-FLAG
	       SG-IN-SWAPPED-STATE
	       SG-INITIAL-FUNCTION-INDEX
	       SG-INST-DISP
	       SG-INST-DISPATCHES
 	       SG-M3-M4-TAGS
 	       SG-MAIN-DISPATCH
	       SG-NAME
	       SG-PDL-PHASE
	       SG-PREVIOUS-STACK-GROUP
	       SG-PROCESSING-ERROR-FLAG
	       SG-PROCESSING-INTERRUPT-FLAG
	       SG-RECOVERY-HISTORY
	       SG-REGULAR-PDL
	       SG-REGULAR-PDL-LIMIT
	       SG-REGULAR-PDL-POINTER
	       SG-RESTORE-MICROSTACK
	       SG-RESUMABLE-P
	       SG-SAFE
	       SG-SAVED-M-FLAGS
	       SG-SAVED-VMA
	       SG-SINGLE-STEP-DISPATCH
	       SG-SINGLE-STEP-TRAP
	       SG-SPECIAL-PDL
	       SG-SPECIAL-PDL-LIMIT
	       SG-SPECIAL-PDL-POINTER
	       SG-STATE
	       SG-STATE-ACTIVE
	       SG-STATE-AWAITING-CALL
	       SG-STATE-AWAITING-ERROR-RECOVERY
	       SG-STATE-AWAITING-INITIAL-CALL
	       SG-STATE-AWAITING-RETURN
	       SG-STATE-ERROR
	       SG-STATE-EXHAUSTED
	       SG-STATE-FIELDS
	       SG-STATE-INTERRUPTED-DIRTY
	       SG-STATE-INVOKE-CALL-ON-RETURN
	       SG-STATE-RESUMABLE
	       SG-STATES
	       SG-SWAP-SV-OF-SG-THAT-CALLS-ME
	       SG-SWAP-SV-ON-CALL-OUT
	       SG-TOP-FRAME
	       SG-TRAP-AP-LEVEL
	       SG-TRAP-MICRO-PC
	       SG-TRAP-TAG
 	       SG-VMA-M1-M2-TAGS
	       SHIFT-LOCK-XORS
	       SHRINK-PDL-SAVE-TOP
	       SIMPLE-ARRAY-P
               SIMPLE-MAKE-ARRAY
	       SIMPLE-PROCESS
	       SINGLE-FLOATP 
	       SINGLE-TO-DOUBLE-FLOAT-EXPONENT-DIFFERENCE
	       SIZE-OF-AREA-ARRAYS
	       SIZE-OF-HARDWARE-A-MEMORY
	       SIZE-OF-HARDWARE-CONTROL-MEMORY
	       SIZE-OF-HARDWARE-DISPATCH-MEMORY
	       SIZE-OF-HARDWARE-LEVEL-1-MAP
	       SIZE-OF-HARDWARE-LEVEL-2-MAP
	       SIZE-OF-HARDWARE-M-MEMORY
	       SIZE-OF-HARDWARE-MICRO-STACK
	       SIZE-OF-HARDWARE-PDL-BUFFER
	       SIZE-OF-OB-TBL
	       SIZE-OF-REGION-ARRAYS
	       SPECIAL-PDL-INDEX               
	       SPECIAL-PDL-LEADER-QS
	       SPECIAL-PDL-SG
	       SPECIAL-PDL-SG-HEAD-POINTER
	       SPECPDL-FIELDS
	       STACK-GROUP-HEAD-LEADER-QS
	       STANDARDIZE-FUNCTION-SPEC
	       STORE-KEYWORD-ARG-VALUES
	       SUBLIS-EVAL-ONCE
	       SUBST-EXPAND
	       SUPPORT-ENTRY-VECTOR
	       SWAP-STATUS
	       SYMBOL-NAME-CONFLICT
	       SYSTEM-COMMUNICATION-AREA
	       SYSTEM-COMMUNICATION-AREA-QS
	       SYSTEM-INITIALIZATION-LIST
	       SYSTEM-VERSION-INFO
	       TARGET-BINARY-FILE-TYPE
	       TEST
 	       TIME-IN-60THS
	       TRANSMIT-BAND
	       TYPEP-STRUCTURE-OR-FLAVOR
	       UNADVISE-1
	       UNBIND-1
	       UNBIND-2
	       UNBIND-3
	       UNBIND-4
	       UNBIND-5
	       UNBIND-6
	       UNBIND-7
	       UNBIND-10
	       UNBIND-11
	       UNBIND-12
	       UNBIND-13
	       UNBIND-14
	       UNBIND-15
	       UNBIND-16
	       UNBIND-TO-INDEX
	       UNBIND-TO-INDEX-MOVE              
	       UNBUFFERED-LINE-INPUT-STREAM
	       UNDO-DECLARATIONS-FLAG
	       UNDOABLE-FORMS-1
	       UNENCAPSULATE-FUNCTION-SPEC
	       UNFASL
	       UNFASL-PRINT
	       UNWIRE-PAGE
	       UPDATE-PARTITION-COMMENT
	       USER-INIT-OPTIONS
 	       VALIDATE-FUNCTION-SPEC
	       VANILLA-FLAVOR
	       WARM-INITIALIZATION-LIST
	       WIRE-PAGE
	       WITH-SELF-ACCESSIBLE
	       XR-XRTYI
	       XR-XRUNTYI
 	       
;; Standard fundamental error flavors
	       
	       AUTOMATIC-ABORT-DEBUGGER-MIXIN
	       NO-ACTION-MIXIN
	       PROCEED-WITH-VALUE-MIXIN
	       WARNING
	       
;; Standard error flavors
	       
	       ARITHMETIC-ERROR
	       BAD-ARRAY-MIXIN
	       CELL-CONTENTS-ERROR
	       END-OF-FILE
	       PACKAGE-ERROR
	       PACKAGE-LOCKED
	       PACKAGE-NOT-FOUND
	       READ-END-OF-FILE
	       READ-ERROR
	       UNBOUND-VARIABLE
	       
;; A few signal-names, not advertised, but here for communication with signalers
	       
	       READ-ERROR-1
	       END-OF-FILE-1
	       
;; Standard error condition names
	       
	       ABORT
	       AREA-OVERFLOW
	       ARRAY-HAS-NO-LEADER
	       ARRAY-WRONG-NUMBER-OF-DIMENSIONS
	       BAD-ARRAY-ERROR
	       BAD-ARRAY-TYPE
	       BAD-CDR-CODE
	       BAD-DATA-TYPE-IN-MEMORY
	       BAD-INTERNAL-MEMORY-SELECTOR-ARG
	       BAD-KEYWORD-ARGLIST
	       BIGNUM-NOT-BIG-ENOUGH-DPB
	       BITBLT-DESTINATION-TOO-SMALL
	       BREAK-CONDITION
	       BREAKPOINT
	       CALL-TRAP
	       CONS-IN-FIXED-AREA
	       CONS-ZERO-SIZE
	       DATA-TYPE-SCREWUP
	       DISK-ERROR
	       DIVIDE-BY-ZERO
	       DRAW-OFF-END-OF-SCREEN
	       DRAW-ON-UNPREPARED-SHEET
	       EXIT-TRAP
	       FAILED-ASSERTION
	       FILL-POINTER-NOT-FIXNUM
	       FIXNUM-OVERFLOW
	       FLOATING-EXPONENT-OVERFLOW
	       FLOATING-EXPONENT-UNDERFLOW
	       FUNCALL-MACRO
	       HOST-NOT-RESPONDING
	       IALLB-TOO-SMALL
	       ILLEGAL-INSTRUCTION
	       INVALID-FORM
	       INVALID-FUNCTION
	       INVALID-FUNCTION-SPEC
	       INVALID-LAMBDA-LIST
	       LOCK-TIMEOUT
	       MICRO-CODE-ENTRY-OUT-OF-RANGE
	       MISSING-CLOSEPAREN
	       MVR-BAD-NUMBER
	       NEGATIVE-SQRT
	       NO-MAPPING-TABLE
	       NO-MAPPING-TABLE-1
	       NON-POSITIVE-LOG
	       NUMBER-ARRAY-NOT-ALLOWED
	       PACKAGE-ERROR
	       PACKAGE-NOT-FOUND
	       PACKAGE-NOT-FOUND-1
	       PARSE-ERROR
	       PARSE-FERROR
	       PDL-OVERFLOW
	       PRINT-NOT-READABLE
	       READ-LIST-END-OF-FILE
	       READ-PACKAGE-NOT-FOUND
	       READ-STRING-END-OF-FILE
	       READ-SYMBOL-END-OF-FILE
	       REDEFINITION
	       REGION-TABLE-OVERFLOW
	       RPLACD-WRONG-REPRESENTATION-TYPE
	       SELECT-METHOD-BAD-SUBROUTINE-CALL
	       SELECT-METHOD-GARBAGE-IN-SELECT-METHOD-LIST
	       SELECTED-METHOD-NOT-FOUND
	       SELF-NOT-INSTANCE
	       SHUTDOWN
	       SIMPLE-VECTOR-SIZE-P
	       STACK-FRAME-TOO-LARGE
	       STEP-BREAK
	       STREAM-CLOSED
	       STREAM-INVALID
	       STRING-EQUAL*
	       STRING=*
	       SUBSCRIPT-OUT-OF-BOUNDS
	       SYMBOL-FROM-VALUE-CELL-LOCATION
	       SYMBOL-NAME-CONFLICT
	       TAPE-ERROR
	       THROW-EXIT-TRAP
	       THROW-TAG-NOT-SEEN
	       TOO-FEW-ARGUMENTS
	       TOO-MANY-ARGUMENTS
	       TYPE-CANONICALIZE
	       UNBOUND-CLOSURE-VARIABLE
	       UNBOUND-INSTANCE-VARIABLE
	       UNBOUND-LOCAL-VARIABLE		;Never signaled, at the present time.
	       UNBOUND-SPECIAL-VARIABLE
	       UNBOUND-SYMBOL
	       UNBOUND-VARIABLE
	       UNCLAIMED-MESSAGE
	       UNDEFINED-FUNCTION
	       UNDEFINED-KEYWORD-ARGUMENT
	       UNKNOWN-LOCF-REFERENCE
	       UNKNOWN-SETF-REFERENCE
	       VIRTUAL-MEMORY-OVERFLOW
	       WRITE-IN-READ-ONLY
	       WRONG-STACK-GROUP-STATE
	       WRONG-TYPE-ARGUMENT
	       ZERO-ARGS-TO-SELECT-METHOD
	       ZERO-LOG
	       ZERO-TO-NEGATIVE-POWER
	       SI:*APPEND  
	  SI:*NCONC
	  SI:MEMBER-TEST
	  SI:MEMBER-EQUAL
	  SI:MEMBER-EQL
	  SI:MEMBER-EQUALP
	  SI:MEMBER* 
	  SI:MEMBER-IF*
	  SI:MEMBER-IF-NOT*
	  SI:ASSOC-TEST
	  SI:ASSOC-EQUAL
	  SI:ASSOC-EQL
	  SI:ASSOC-EQUALP
	  SI:ASSOC-TESTNOT
	  SI:RASSOC-EQUAL
	  SI:RASSOC-TEST
	  SI:RASSOC-TESTNOT
	  SI:RASSOC-EQL 
	  SI:RASSOC-EQUALP
	  SI:ADJOIN-TEST
	  SI:ADJOIN* 
	  SI:SUBST-EQUAL
	  SI:SUBST-EQL
	  SI:SUBST*
	  SI:SUBST-IF*
	  SI:SUBST-IF-NOT*
	  SI:NSUBST* 
	  SI:NSUBST-IF*
	  SI:NSUBST-IF-NOT*
	  SI:SUBLIS* 
	  SI:NSUBLIS*
	  SI:INTERSECTION*
	  SI:NINTERSECTION*
	  SI:SET-DIFFERENCE*
	  SI:NSET-DIFFERENCE*
	  SI:UNION-TEMPLATE
	  SI:UNION*
	  SI:NUNION-TEMPLATE
	  SI:NUNION*
	  SI:NSET-EXCLUSIVE-OR*
	  SI:SET-EXCLUSIVE-OR*
	  SI:SUBSETP*   ;; <----- LAST SYMBOL FROM LISTS
	  SI:INTERNAL-MAKE-VECTOR   ;; <---- SEQUENCES1
	  SI:ADJUST-VECTOR
	  SI:REPLACE*
	  SI:REVERSE-LIST
	  SI:REVERSE-VECTOR
	  SI:NREVERSE-LIST
	  SI:NREVERSE-VECTOR
	  SI:REDUCE-VECTOR
	  SI:REDUCE-LIST
	  SI:REDUCE*
	  SI:FILL-VECTOR
	  SI:FILL-LIST
	  SI:FILL*		  ;; <---------- LAST SYMBOL FROM SEQUENCES1
	  SI:SEARCH*
	  SI:SEARCH*-LIST
	  SI:SEARCH*-LIST-EQ-OR-EQL
	  SI:SEARCH*-STRING-CASE
	  SI:SEARCH*-STRING-CASE-FROMEND
	  SI:SEARCH*-STRING-NOCASE
	  SI:SEARCH*-STRING-NOCASE-FROMEND
	  SI:SEARCH*-VECTOR
	  SI:SEARCH*-VECTOR-EQL
	  SI:SEARCH*-VECTOR-FROMEND
	  SI:COPY-ARRAY-BELOW-INDEX
	  SI:COPY-LIST-BELOW-INDEX
	  SI:DELETE-LIST
	  SI:DELETE-IF-LIST
	  SI:DELETE-IF-NOT-LIST
	  SI:DELETE-VECTOR
	  SI:DELETE-IF-VECTOR
	  SI:DELETE-IF-NOT-VECTOR
	  SI:DELETE-IF*
	  SI:DELETE-IF-NOT*
	  SI:DELETE*
	  SI:DELETE-LIST-EQ
	  SI:DELETE-LIST-EQUAL
	  SI:DELETE-LIST-EQL
	  SI:REMOVE-LIST
	  SI:REMOVE-IF-LIST
	  SI:REMOVE-IF-NOT-LIST
	  SI:REMOVE-VECTOR
	  SI:REMOVE-IF-VECTOR
	  SI:REMOVE-IF-NOT-VECTOR
	  SI:REMOVE-IF*
	  SI:REMOVE-IF-NOT*
	  SI:REMOVE*
	  SI:REMOVE-LIST-EQ
	  SI:REMOVE-LIST-EQUAL
	  SI:REMOVE-LIST-EQL
	  SI:DELETE-DUPLICATES-LIST
	  SI:DELETE-DUPLICATES-LIST-EQL
	  SI:DELETE-DUPLICATES-VECTOR
	  SI:DELETE-DUPLICATES*
	  SI:REMOVE-DUPLICATES-LIST
	  SI:REMOVE-DUPLICATES-LIST-EQL
	  SI:REMOVE-DUPLICATES-VECTOR
	  SI:REMOVE-DUPLICATES*
	  SI:FIND-LIST
	  SI:FIND-IF-LIST
	  SI:FIND-IF-NOT-LIST
	  SI:FIND-VECTOR
	  SI:FIND-IF-VECTOR
	  SI:FIND-IF-NOT-VECTOR
	  SI:FIND*
	  SI:FIND-IF*
	  SI:FIND-IF-NOT*
	  SI:POSITION*
	  SI:POSITION-IF*
	  SI:POSITION-IF-NOT*
	  SI:NSUBSTITUTE-LIST
	  SI:NSUBSTITUTE-IF-LIST
	  SI:NSUBSTITUTE-IF-NOT-LIST
	  SI:NSUBSTITUTE-VECTOR
	  SI:NSUBSTITUTE-IF-VECTOR
	  SI:NSUBSTITUTE-IF-NOT-VECTOR
	  SI:NSUBSTITUTE*
	  SI:NSUBSTITUTE-IF*
	  SI:NSUBSTITUTE-IF-NOT*
	  SI:SUBSTITUTE-LIST
	  SI:SUBSTITUTE-IF-LIST
	  SI:SUBSTITUTE-IF-NOT-LIST
	  SI:SUBSTITUTE-VECTOR
	  SI:SUBSTITUTE-IF-VECTOR
	  SI:SUBSTITUTE-IF-NOT-VECTOR
	  SI:SUBSTITUTE*
	  SI:SUBSTITUTE-IF*
	  SI:SUBSTITUTE-IF-NOT*
	  SI:COUNT-LIST
	  SI:COUNT-IF-LIST
	  SI:COUNT-IF-NOT-LIST
	  SI:COUNT-VECTOR
	  SI:COUNT-IF-VECTOR
	  SI:COUNT-IF-NOT-VECTOR
	  SI:COUNT*
	  SI:COUNT-IF*
	  SI:COUNT-IF-NOT*))

))



#!C
; From file  flavor.LISP#> kernel; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL;  flavor.É#É"


(DEFUN SYS::COMPILE-AT-APPROPRIATE-TIME (SYS::FL SYS::NAME SYS::LAMBDA-EXP &OPTIONAL SYS::FORM-TO-EVAL)
  (LET ((*PACKAGE*
	 (IF COMPILER::QC-FILE-IN-PROGRESS
	   *PACKAGE*
	   (SYS::FLAVOR-DEFINITION-PACKAGE SYS::FL)))
	(COMPILER:CHECK-CONFORMANCE NIL))
    (DECLARE (SPECIAL COMPILER:CHECK-CONFORMANCE))
    (IF (AND COMPILER::QC-FILE-IN-PROGRESS COMPILER::QCOMPILE-TEMPORARY-AREA)
      (IF SYS::*JUST-COMPILING*
	(COMPILER:QC-TRANSLATE-FUNCTION
	 (IF (AND (= 4 (LENGTH SYS::NAME)) (EQ (THIRD SYS::NAME) :COMBINED))
	   (LIST* (FIRST SYS::NAME) (SECOND SYS::NAME) 'SYS:FASLOAD-COMBINED (CDDDR SYS::NAME))
	   SYS::NAME)
	 SYS::LAMBDA-EXP 'COMPILER:MACRO-COMPILE 'COMPILER:QFASL SYS::NAME)
	(COMPILER:LOCKING-RESOURCES-NO-QFASL
	 (LET ((INHIBIT-FDEFINE-WARNINGS T))
	   (PUSH (LIST SYS::NAME SYS:FDEFINE-FILE-PATHNAME) SYS:*FLAVOR-COMPILATIONS*)
	   (COMPILER:QC-TRANSLATE-FUNCTION SYS::NAME SYS::LAMBDA-EXP 'COMPILER:MACRO-COMPILE
					   'COMPILER:COMPILE-TO-CORE))))
      (PROGN
	(PUSH (LIST SYS::NAME SYS:FDEFINE-FILE-PATHNAME) SYS:*FLAVOR-COMPILATIONS*)
	(LET ((SYS:FDEFINE-FILE-PATHNAME NIL)
	      (INHIBIT-FDEFINE-WARNINGS T))
	  (FUNCALL (IF (FBOUNDP 'COMPILE)
		     'COMPILE
		     'FDEFINE) SYS::NAME SYS::LAMBDA-EXP))))
    (AND SYS::FORM-TO-EVAL
       (IF SYS::*JUST-COMPILING*
	 (COMPILER::FASD-FORM SYS::FORM-TO-EVAL)
	 (EVAL SYS::FORM-TO-EVAL)))))

(DEFUN SYS::COMPILE-FLAVOR-METHODS-1 (SYS::FLAVOR-NAME)
  (LET ((SYS::*INTEGRATE-COMBINED-METHODS*
	 (OR SYS::*INTEGRATE-COMBINED-METHODS*
	    (AND (FBOUNDP 'COMPILER:SPEED-OVER-SAFETY-P)
	       (DONT-OPTIMIZE (COMPILER:SPEED-OVER-SAFETY-P))))))
    (COND
      ((SYS::JUST-COMPILING)
       (LET ((SYS::*JUST-COMPILING* T)
	     (SYS::*USE-OLD-COMBINED-METHODS* NIL)
	     (COMPILER:CHECK-CONFORMANCE NIL)
	     SYS::FL)
	 (DECLARE (SPECIAL COMPILER:CHECK-CONFORMANCE))
	 (COND
	   ((SYS::FLAVOR-COMPONENTS-DEFINED-P SYS::FLAVOR-NAME 'COMPILE-FLAVOR-METHODS)
	    (SETQ SYS::FL (SYS::COMPILATION-FLAVOR SYS::FLAVOR-NAME))
	    (AND (EQ SYS::FL (GET SYS::FLAVOR-NAME 'SYS::FLAVOR))
	       (SYS::COMPILATION-DEFINE-FLAVOR SYS::FLAVOR-NAME
					       (SETQ SYS::FL
						     (SYS::FLAVOR-REDEFINITION-FOR-COMPILATION
						      SYS::FL NIL))))
	    (OR (SYS::FLAVOR-DEPENDS-ON-ALL SYS::FL) (SYS::COMPOSE-FLAVOR-COMBINATION SYS::FL))
	    (SYS::COMPOSE-METHOD-COMBINATION SYS::FL NIL)
	    (DOLIST (SYS::ALTERNATIVE (SYS::GET-RUN-TIME-ALTERNATIVE-FLAVOR-NAMES SYS::FL))
	      (SYS::COMPILE-FLAVOR-METHODS-1 SYS::ALTERNATIVE))))))
      (SYS::*INTEGRATE-COMBINED-METHODS* (SYS::INTEGRATE-FLAVOR-METHODS SYS::FLAVOR-NAME)))))


))


#!C
; From file functions.LISP#> READER-macros; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; reader-macros.É#É"

(DEFSUBST SYS::SHARP-NON-STANDARD (CHARACTER)
  (UNLESS SYS:*READ-ACCEPT-EXTENSIONS*
    (COMPILER:CONFORMANCE-WARNING "reader macro #~A" CHARACTER))
  (VALUES))


(DEFUN SYS::SHARP-BACKQUOTE (STREAM SYS::DISPATCH-CHAR IGNORE)
  (SYS::SHARP-NON-STANDARD SYS::DISPATCH-CHAR)
  (PROG ((SYS::FLAG NIL)
	 (SYS::THING NIL)
	 (SYS::**BACKQUOTE-REPEAT-VARIABLE-LISTS**
	  (CONS NIL SYS::**BACKQUOTE-REPEAT-VARIABLE-LISTS**)))
    (MULTIPLE-VALUE-SETQ (SYS::FLAG SYS::THING)
      (SYS::BACKQUOTIFY (READ-PRESERVING-WHITESPACE STREAM T NIL T)))
    (AND (EQ SYS::FLAG SYS::|**BACKQUOTE-,@-FLAG**|)
       (RETURN
	(CERROR ':NO-ACTION NIL 'SYS:READ-ERROR-1 " \",@\" right after a \"`\": `,@~S."
		SYS::THING)))
    (AND (EQ SYS::FLAG SYS::|**BACKQUOTE-,.-FLAG**|)
       (RETURN
	(CERROR ':NO-ACTION NIL 'SYS:READ-ERROR-1 " \",.\" right after a \"`\": `,.~S."
		SYS::THING)))
    (RETURN
     (CONS 'PROGN
	   (NREVERSE
	    (SYS:*EVAL
	     `(LET (SYS::ACCUM)
		(DO ,(CAR SYS::**BACKQUOTE-REPEAT-VARIABLE-LISTS**)
		    ((NULL ,(CAAAR SYS::**BACKQUOTE-REPEAT-VARIABLE-LISTS**))
		     SYS::ACCUM)
		  (PUSH ,(SYS::BACKQUOTIFY-1 SYS::FLAG SYS::THING) SYS::ACCUM)))))))))



(DEFUN SYS::SHARP-COMMA (STREAM IGNORE &OPTIONAL IGNORE)
  (IF SYS:FILE-IN-COLD-LOAD
    (CERROR ':NO-ACTION NIL 'SYS:READ-ERROR-1 "#, cannot be used in files in the cold load."))
  (WHEN (AND (BOUNDP COMPILER:CHECK-CONFORMANCE) (EQ COMPILER:CHECK-CONFORMANCE ':ANSI))
    (COMPILER:CONFORMANCE-WARNING "reader macro #, should be replaced by special form ~S."
				  'LOAD-TIME-VALUE))
  (IF (AND (BOUNDP 'COMPILER::QC-FILE-READ-IN-PROGRESS) COMPILER::QC-FILE-READ-IN-PROGRESS)
    (CONS COMPILER:EVAL-AT-LOAD-TIME-MARKER (READ-PRESERVING-WHITESPACE STREAM T NIL T))
    (VALUES
     (IF *READ-SUPPRESS*
       (PROGN
	 (READ-PRESERVING-WHITESPACE STREAM T NIL T)
	 NIL)
       (SYS:*EVAL (READ-PRESERVING-WHITESPACE STREAM T NIL T))))))

(DEFUN SYS::|XR-#Ò-MACRO| (STREAM SYS::DISPATCH-CHAR IGNORE)
  (IF *READ-SUPPRESS*
    (PROGN
      (READ-DELIMITED-LIST #\Ó STREAM T)
      NIL)
    (PROGN
      (SYS::SHARP-NON-STANDARD SYS::DISPATCH-CHAR)
      (LET* ((SYS::FLAVOR-NAME
	      (LET ((*PACKAGE* SYS::PKG-USER-PACKAGE))
		(READ-PRESERVING-WHITESPACE STREAM T NIL T)))
	     (INSTANCE
	      (LET ((SYS::HANDLER
		     (OR (GET SYS::FLAVOR-NAME 'SYS::READ-INSTANCE)
			(SYS::GET-FLAVOR-HANDLER-FOR SYS::FLAVOR-NAME ':READ-INSTANCE)))
		    (SELF NIL))
		(FUNCALL SYS::HANDLER ':READ-INSTANCE SYS::FLAVOR-NAME STREAM)))
	     (CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL T)))
	(IF (EQL CHAR #\Ó)
	  INSTANCE
	  (PROGN
	    (WHEN CHAR
	      (UNREAD-CHAR CHAR STREAM))
	    (CERROR ':NO-ACTION NIL 'SYS:READ-ERROR-1
		    "Malformatted #Ò~S...Ó encountered during READ." SYS::FLAVOR-NAME)))))))

(DEFUN SYS::|XR-#!-MACRO| (STREAM SYS::DISPATCH-CHAR &OPTIONAL IGNORE)
  (SYS::SHARP-NON-STANDARD SYS::DISPATCH-CHAR)
  (CASE (SYS::INTERNAL-READ-CHAR STREAM)
    ((#\C #\c) (WITH-COMMON-LISP-ON (VALUES (READ-PRESERVING-WHITESPACE STREAM T NIL T))))
    ((#\Z #\z) (WITH-ZETALISP-ON (VALUES (READ-PRESERVING-WHITESPACE STREAM T NIL T))))
    (T (CERROR ':NO-ACTION NIL 'SYS:READ-ERROR-1 "Unknown Lisp Mode option in #! Reader Macro"))))

))




#!C
; From file infix.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; infix.É#É"

(DEFUN SYS::INFIX-TOPLEVEL-PARSE (*STANDARD-INPUT* SYS::DISPATCH-CHAR IGNORE)
  (SYS::SHARP-NON-STANDARD SYS::DISPATCH-CHAR)
  (LET ((SYS::INFIX-TOKEN (SYS::INFIX-READ-TOKEN)))
    (SYS::INFIX-PARSE -1)))

))

#!C
; From file structure.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; structure.É#É"



(DEFUN SYS::MAKE-CALLABLE-ACCESSORS NIL
  (SYS::USING-DEFSTRUCT-SPECIAL-VARIABLES)
  (LET ((SYS::CODE (SYS::DEFSTRUCT-TYPE-DESCRIPTION-ACCESSOR-CODE SYS::TYPE-DESCRIPTION))
	(SYS::N-ARGS (SYS::DEFSTRUCT-TYPE-DESCRIPTION-REF-NO-ARGS SYS::TYPE-DESCRIPTION))
	(SYS::ARG-NAME SYS::NAME)
	(SYS::CHECKED-ARG SYS::NAME)
	ARGLIST
	SYS::JUNKPART)
    (DECLARE (NOTINLINE COMPILER::VALIDATE-TYPES-P))
    (WHEN (AND (BOUNDP 'COMPILER::OPTIMIZE-SWITCH)
	(> (COMPILER::OPT-SAFETY COMPILER::OPTIMIZE-SWITCH)
	   (COMPILER::OPT-SPEED-OR-SPACE COMPILER::OPTIMIZE-SWITCH)))
      (SETQ SYS::ARG-NAME (COPY-SYMBOL SYS::NAME))
      (SETQ SYS::CHECKED-ARG `(THE ,SYS::NAME ,SYS::ARG-NAME)))
    (SETF SYS::JUNKPART
	  (IF (> SYS::N-ARGS 1)
	    (MAPCAR #'(LAMBDA (SYS::X)
			SYS::X
			(GENTEMP)) (MAKE-LIST (1- SYS::N-ARGS)))
	    NIL))
    (SETF ARGLIST
	  `(,@SYS::JUNKPART
	    ,@(IF SYS::DEFAULT-POINTER
		`(&OPTIONAL (,SYS::ARG-NAME ,SYS::DEFAULT-POINTER))
		`(,SYS::ARG-NAME))))
    (DOLIST (SYS::SLOT SYS::SLOT-ALIST)
      (LET* ((SYS::DOC (SYS::DEFSTRUCT-SLOT-DESCRIPTION-DOCUMENTATION (REST SYS::SLOT)))
	     (SYS::N (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NUMBER (REST SYS::SLOT)))
	     (SYS::REF
	      (APPLY SYS::CODE SYS::N
		     (APPEND
		      (IF SYS::BUT-FIRST
			`((,SYS::BUT-FIRST ,SYS::CHECKED-ARG))
			(LIST SYS::CHECKED-ARG))
		      SYS::JUNKPART)))
	     (SYS::PPSS (SYS::DEFSTRUCT-SLOT-DESCRIPTION-PPSS (REST SYS::SLOT)))
	     (SYS::ACCESSOR
	      (IF SYS::CONC-NAME
		(SYS::CREATE-SYMBOL SYS::CONC-NAME (FIRST SYS::SLOT))
		(FIRST SYS::SLOT))))
	(SETF (SYS::DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (REST SYS::SLOT)) SYS::ACCESSOR)
	(UNLESS (OR (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NAME-SLOT-P (REST SYS::SLOT))
	    (AND SYS::INCLUDE
	       (EQ SYS::ACCESSOR
		   (SYS::DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME
		    (CDR
		     (ASSOC (CAR SYS::SLOT)
			    (SYS::DEFSTRUCT-DESCRIPTION-SLOT-ALIST
			     (SYS::GET-DEFSTRUCT-DESCRIPTION (CAR SYS::INCLUDE)))
			    :TEST #'EQ))))))
	  (SETF (SYS::DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (REST SYS::SLOT)) SYS::ACCESSOR)
	  (PROGN
	    (PUSH `(EVAL-WHEN (COMPILE)
		     (PUTDECL ',SYS::ACCESSOR NIL 'SYS::SETF-METHOD))
	       SYS::RETURNS)
	    (PUSH `(EVAL-WHEN (LOAD EVAL)
		     (REMPROP ',SYS::ACCESSOR 'SYS::SETF-METHOD))
	       SYS::RETURNS))
	  (IF (SYS::DEFSTRUCT-SLOT-DESCRIPTION-READ-ONLY (REST SYS::SLOT))
	    (SYS::DEFSTRUCT-PUTPROP-COMPILE-TIME SYS::ACCESSOR
	       (FUNCTION SYS::READ-ONLY-SLOT-SETF-METHOD) 'SYS::SETF-METHOD))
	  (PUSH
	   `(DEFSUBST ,SYS::ACCESSOR ,ARGLIST
	      ,@(IF SYS::DOC
		  `(,SYS::DOC)
		  NIL)
	      ,SYS::FUNCTION-PARENT-DECLARATION
	      ,(IF (NULL SYS::PPSS)
		 (LET ((SYS::SLOT-TYPE (SYS::DEFSTRUCT-SLOT-DESCRIPTION-TYPE (REST SYS::SLOT))))
		   (IF (OR (SYS::EMPTYP SYS::SLOT-TYPE) (EQ SYS::SLOT-TYPE 'T)
		       (LET ((SYS::INITFORM
			      (SYS::DEFSTRUCT-SLOT-DESCRIPTION-INIT-CODE (REST SYS::SLOT))))
			 (WHEN (AND (CONSTANTP SYS::INITFORM) (TYPE-SPECIFIER-P SYS::SLOT-TYPE NIL)
			     (IGNORE-ERRORS
			      (NOT
			       (TYPEP (COMPILER:EVAL-FOR-TARGET SYS::INITFORM) SYS::SLOT-TYPE))))
			   (SYS:NON-FATAL-ERROR ':IGNORABLE-MISTAKE
						"The init form for slot ~S is ~S which is inconsistent with its type declaration of ~S."
						(CAR SYS::SLOT) SYS::INITFORM SYS::SLOT-TYPE)
			   T))
		       (EQ SYS::SLOT-TYPE SYS::ARG-NAME)
		       (AND (CONSP SYS::SLOT-TYPE)
			  (MEMBER SYS::ARG-NAME SYS::SLOT-TYPE :TEST #'EQ)))
		     SYS::REF
		     `(THE ,SYS::SLOT-TYPE ,SYS::REF)))
		 `(LDB ,SYS::PPSS ,SYS::REF)))
	   SYS::RETURNS))))
    SYS::RETURNS)) 


(DEFUN SYS::MAKE-CALLABLE-CONSTRUCTOR (SYS::CONS-NAME)
  (SYS::USING-DEFSTRUCT-SPECIAL-VARIABLES)
  (LET ((SYS::SLOT-DEFAULTS (SYS::COLLECT-SLOT-DEFAULTS SYS::SLOT-ALIST))
	(SYS::CODE (SYS::DEFSTRUCT-TYPE-DESCRIPTION-ACCESSOR-CODE SYS::TYPE-DESCRIPTION))
	SYS::KEYS
	SYS::VAL
	(SYS::MISSING (GENSYM)))
    (DOLIST (SYS::KEY (SYS::DEFSTRUCT-TYPE-DESCRIPTION-DEFSTRUCT-KEYWORDS SYS::TYPE-DESCRIPTION))
      (UNLESS (GET SYS::KEY SYS::KEYS)
	(WHEN (SETF SYS::VAL (SYS::GET-DEFSTRUCT-PROPERTY-VALUE SYS::NAME SYS::KEY))
	  (PUSH SYS::VAL SYS::KEYS)
	  (PUSH SYS::KEY SYS::KEYS))))
    (PUSH
     `(DEFUN ,SYS::CONS-NAME (&REST SYS::INITS)
	(DECLARE (SYS:FUNCTION-PARENT ,SYS::NAME))
	(DO ((SYS::INITS SYS::INITS (CDDR SYS::INITS))
	     (STRUCTURE
	      ,(APPLY (SYS::DEFSTRUCT-TYPE-DESCRIPTION-BARE-CONSTRUCTOR SYS::TYPE-DESCRIPTION)
		      SYS::NAME SYS::SIZE SYS::SUBTYPE (SYS::NAME-OFFSET) SYS::KEYS))
	     (SYS::ALLOW-OTHER-KEYS-P NIL)
	     (SYS::ALLOW-OTHER-KEYS NIL)
	     (SYS::PROCESSED-INITS NIL)
	     ,@(IF SYS::SLOT-DEFAULTS
		 '(SYS::SLOT-DONE)
		 NIL))
	    ((NULL SYS::INITS)
	     ,@(AND
		(AND (NOT (SYS::DEFSTRUCT-TYPE-DESCRIPTION-NAMED-P SYS::TYPE-DESCRIPTION))
		   (<= 1 (SYS::DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD SYS::TYPE-DESCRIPTION)))
		(MAPCAN
		 #'(LAMBDA (SYS::X)
		     (IF (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NAME-SLOT-P (CDR SYS::X))
		       (LIST
			(SYS::SET-SLOT SYS::CODE 'STRUCTURE
			   (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NUMBER (CDR SYS::X))
			   (SYS::DEFSTRUCT-SLOT-DESCRIPTION-INIT-CODE (CDR SYS::X))))
		       NIL))
		 SYS::SLOT-ALIST))
	     ,@(IF SYS::SLOT-DEFAULTS
		 (DO ((SYS::DEFAULTS SYS::SLOT-DEFAULTS (CDR SYS::DEFAULTS))
		      (SYS::PRODUCED-CODE '(STRUCTURE)))
		     ((NULL SYS::DEFAULTS)
		      SYS::PRODUCED-CODE)
		   (PUSH
		    `(UNLESS (MEMBER ,(CAAR SYS::DEFAULTS) SYS::SLOT-DONE :TEST #'EQ)
		       ,(IF (SYS::CHECK-FOR-BYTE-SLOTS SYS::SLOT-ALIST)
			  (IF (NULL (CDDDAR SYS::DEFAULTS))
			    (SYS::SET-SLOT SYS::CODE 'STRUCTURE (CADDAR SYS::DEFAULTS)
			       (CADAR SYS::DEFAULTS))
			    (SYS::SET-SLOT SYS::CODE 'STRUCTURE (CADDAR SYS::DEFAULTS)
			       (CADAR SYS::DEFAULTS) (CDDDAR SYS::DEFAULTS)))
			  (SYS::SET-SLOT SYS::CODE 'STRUCTURE (CADDAR SYS::DEFAULTS)
			     (CADAR SYS::DEFAULTS))))
		    SYS::PRODUCED-CODE))
		 '(STRUCTURE)))
	  (LET ((SYS::SLOT-NUMBER
		 (CDR
		  (ASSOC (CAR SYS::INITS)
			 ',(MAPCAN
			    #'(LAMBDA (SYS::X)
				(IF (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NAME-SLOT-P (CDR SYS::X))
				  NIL
				  (LIST
				   (CONS (INTERN (SYMBOL-NAME (CAR SYS::X)) 'KEYWORD)
					 (CONS
					  (SYS::DEFSTRUCT-SLOT-DESCRIPTION-NUMBER (CDR SYS::X))
					  (SYS::DEFSTRUCT-SLOT-DESCRIPTION-PPSS (CDR SYS::X)))))))
			    SYS::SLOT-ALIST)
			 :TEST #'EQ))))
	    (UNLESS (MEMBER (CAR SYS::INITS) SYS::PROCESSED-INITS)
	      (PUSH (CAR SYS::INITS) SYS::PROCESSED-INITS)
	      (IF SYS::SLOT-NUMBER
		(PROGN
		  ,(IF (SYS::CHECK-FOR-BYTE-SLOTS SYS::SLOT-ALIST)
		     (SYS::SET-SLOT SYS::CODE 'STRUCTURE '(CAR SYS::SLOT-NUMBER)
			'(SECOND SYS::INITS) '(CDR SYS::SLOT-NUMBER))
		     (SYS::SET-SLOT SYS::CODE 'STRUCTURE '(CAR SYS::SLOT-NUMBER)
			'(SECOND SYS::INITS)))
		  ,@(IF SYS::SLOT-DEFAULTS
		      '((PUSH (CAR SYS::INITS) SYS::SLOT-DONE))
		      NIL))
		(OR SYS::ALLOW-OTHER-KEYS
		   (AND (EQ (CAR SYS::INITS) :ALLOW-OTHER-KEYS)
		      (PROGN
			(UNLESS SYS::ALLOW-OTHER-KEYS-P
			  (SETF SYS::ALLOW-OTHER-KEYS (CADR SYS::INITS))
			  (SETF SYS::ALLOW-OTHER-KEYS-P T))
			T))
		   (AND (NULL SYS::ALLOW-OTHER-KEYS-P)
		      (LET ((SYS::P (GETF SYS::INITS :ALLOW-OTHER-KEYS ',SYS::MISSING)))
			(WHEN (NEQ SYS::P ',SYS::MISSING)
			  (SETF SYS::ALLOW-OTHER-KEYS-P T)
			  (SETF SYS::ALLOW-OTHER-KEYS SYS::P))))
		   (ERROR "unknown slot keyword ~S for structure ~S" (CAR SYS::INITS)
			  ',SYS::NAME)))))))
     SYS::RETURNS))) 


))




#!C
; From file setf.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; setf.É#É"

(defmacro sys:seo-count (x) `(cadr ,x))
   
;; The third element is the specified value expression to "substitute".
(defmacro sys:seo-exp (x) `(caddr ,x))
   
;; The fourth element is the temporary variable to hold this value in during execution.
(defmacro sys:seo-tempvar (x) `(cadddr ,x))
   
;; The fifth element points to a PROGN which contains a SETQ
;; that sets the seo-tempvar from the seo-exp.
(defmacro sys:seo-first-use (x) `(fifth ,x))
   





(DEFUN SYS:SUBLIS-EVAL-ONCE (SYS::ALIST EXP &OPTIONAL SYS::REUSE-FLAG SYS::SEQUENTIAL-FLAG
  (SYS::ENVIRONMENT SYS::*MACROEXPAND-ENVIRONMENT*))
  "Effectively substitute for symbols in EXP according to ALIST, preserving execution order.
Each element of ALIST describes one symbol (the car)
and what it stands for (the cdr).
We replace each symbol with the corresponding value expression,
not with straight textual substitution but so that
the value expression will be evaluated only once.

If SEQUENTIAL-FLAG is non-NIL, the value substituted for each symbol
may refer to the previous symbols substituted for.

This may require the use of temporary variables.
The first use of a symbol would be replaced by a SETQ of the tempvar
to the symbol's corresponding expression.  Later uses would be
replaced with just the tempvar.  A LET to bind the tempvars is
wrapped around the whole expression.

If REUSE-FLAG is non-NIL, the symbols themselves can be used
as their own tempvars when necessary.  Otherwise tempvars are gensymmed.

It may be necessary to expand macros in EXP in order to process it.
In this case, ENVIRONMENT is passed as the environment arg to MACROEXPAND.
It defaults to the value of *MACROEXPAND-ENVIRONMENT*, which within a macro's
expander function is bound to the environment of expansion."
  (LET (SYS::CONSTANT-ALIST
	SYS::NONCONSTANT-ALIST
	SYS::VALUE-SO-FAR)
    (DOLIST (ELT SYS::ALIST)
      (LET ((SYS::TEM (IF SYS::SEQUENTIAL-FLAG
			(SUBLIS SYS::CONSTANT-ALIST (CDR ELT))
			(CDR ELT))))
	(IF (CONSTANTP SYS::TEM)
	  (PUSH (IF (EQ SYS::TEM (CDR ELT))
		  ELT
		  (CONS (CAR ELT) SYS::TEM)) SYS::CONSTANT-ALIST)
	  (PUSH (LIST (CAR ELT) 0 SYS::TEM NIL NIL) SYS::NONCONSTANT-ALIST))))
    (SETQ SYS::NONCONSTANT-ALIST (NREVERSE SYS::NONCONSTANT-ALIST))
    (WHEN (LOOP SYS::FOR ELT SYS::IN SYS::NONCONSTANT-ALIST SYS::ALWAYS (SYMBOLP (SYS::SEO-EXP ELT)))
      (DOLIST (ELT SYS::NONCONSTANT-ALIST)
	(PUSH
	 (CONS (CAR ELT)
	       (IF SYS::SEQUENTIAL-FLAG
		 (SUBLIS SYS::CONSTANT-ALIST (SYS::SEO-EXP ELT))
		 (SYS::SEO-EXP ELT)))
	 SYS::CONSTANT-ALIST))
      (SETQ SYS::NONCONSTANT-ALIST NIL))
    (SETQ SYS::VALUE-SO-FAR (SUBLIS SYS::CONSTANT-ALIST EXP))
    (WHEN SYS::NONCONSTANT-ALIST
      (WHEN (OR (NOT (FBOUNDP 'COMPILER::CODE-WALK))
	  (CATCH 'SYS::WALK
	    (COMPILER-LET ((INHIBIT-STYLE-WARNINGS-SWITCH T))
	      (COMPILER::CODE-WALK EXP
				   #'(LAMBDA (SYS::FORM)
				       (WHEN (MEMBER (CAR SYS::FORM)
						'(VARIABLE-LOCATION COND AND OR RETURN
						    RETURN-FROM GO SYS::*CATCH SYS::*THROW CATCH
						    THROW DO DO* SYS::DO-NAMED SYS::DO*-NAMED IF
						    COMMENT)
						:TEST #'EQ)
					 (THROW 'SYS::WALK
						T))
				       SYS::FORM)
				   #'IDENTITY NIL SYS::ENVIRONMENT))
	    NIL))
	(SETQ SYS::VALUE-SO-FAR
	      `(PROGN
		 ,@(MAPCAR 'CAR SYS::NONCONSTANT-ALIST)
		 ,SYS::VALUE-SO-FAR)))
      (LET* ((SYS::SEO-FIRST-UNINSERTED-VAR SYS::NONCONSTANT-ALIST))
	(SETQ SYS::VALUE-SO-FAR
	      (SYS::SUBLIS-EVAL-ONCE-1 SYS::VALUE-SO-FAR SYS::NONCONSTANT-ALIST SYS::REUSE-FLAG
				       SYS::SEQUENTIAL-FLAG))
	(IF SYS::SEO-FIRST-UNINSERTED-VAR
	  (SETQ SYS::VALUE-SO-FAR
		`(MULTIPLE-VALUE-PROG1 ,SYS::VALUE-SO-FAR
		    ,@(IF SYS::SEQUENTIAL-FLAG
			(LIST
			 (SYS::SUBLIS-EVAL-ONCE-1 (CAAR (LAST SYS::NONCONSTANT-ALIST))
						  SYS::NONCONSTANT-ALIST SYS::REUSE-FLAG T))
			(MAPCAR 'CADDR SYS::SEO-FIRST-UNINSERTED-VAR))))))
      (DOLIST (ELT SYS::NONCONSTANT-ALIST)
	(LET ((SYS::TEM (SYS::SEO-FIRST-USE ELT)))
	  (WHEN (ZEROP (SYS::SEO-COUNT ELT))
	    (DO ((SYS::TAIL (CDR SYS::TEM) (CDR SYS::TAIL)))
		((NULL SYS::TAIL))
	      (WHEN (AND (LISTP (CAR SYS::TAIL)) (EQ (CAAR SYS::TAIL) 'SETQ)
		  (EQ (CADAR SYS::TAIL) (SYS::SEO-TEMPVAR ELT)))
		(SETF (CAR SYS::TAIL) (CADDAR SYS::TAIL))
		(RETURN)))))))
    (LET ((SYS::TEMPVARS-USED
	   (LOOP SYS::FOR ELT SYS::IN SYS::NONCONSTANT-ALIST WHEN
	      (NOT (ZEROP (SYS::SEO-COUNT ELT))) SYS::COLLECT
	      (LIST (SYS::SEO-TEMPVAR ELT) '(COMPILER::UNDEFINED-VALUE)))))
      (IF SYS::TEMPVARS-USED
	`(LET ,SYS::TEMPVARS-USED
	   ,SYS::VALUE-SO-FAR)
	SYS::VALUE-SO-FAR)))) 


(DEFUN SYS::PARSE-THE-IN-PLACE (SYS::PLACE)
  (DECLARE (NOTINLINE COMPILER::VALIDATE-TYPES-P))
  (IF (AND (EQ (CAR-SAFE SYS::PLACE) 'THE)
      (COMPILER-LET ((INHIBIT-STYLE-WARNINGS-SWITCH T))
	(NOT (AND (FBOUNDP 'COMPILER::VALIDATE-TYPES-P) (COMPILER::VALIDATE-TYPES-P)))))
    (SYS::PARSE-THE-IN-PLACE (CADR-SAFE (CDR-SAFE SYS::PLACE)))
    SYS::PLACE)) 


(UNLESS (EQ (FIND-SYMBOL "GET" "CL") (FIND-SYMBOL "GET" "SYS"))
  (DEFSETF COMMON-LISP:GET (SYS::OBJECT SYS::PROPERTY &OPTIONAL (SYS::DEFAULT NIL SYS::DEFAULTP)) (SYS::VALUE)
    (LET ((SYS::TEM (IF SYS::DEFAULTP
		      `(PROG1
			 ,SYS::PROPERTY
			 ,SYS::DEFAULT)
		      SYS::PROPERTY)))
      `(SYS::SETF-GET ,SYS::OBJECT ,SYS::TEM ,SYS::VALUE)))) 


(REMPROP 'THE 'SYS::SETF-EXPAND) 


(DEFINE-SETF-METHOD THE (TYPE SYS::FORM)
  (VALUES NIL NIL '(SYS::.STORE.) `(SETF ,SYS::FORM (THE ,TYPE SYS::.STORE.))
	  `(THE ,TYPE ,SYS::FORM))) 


))



#!C
; From file defmacro.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; defmacro.É#É"


(DEFUN COMMON-LISP:PARSE-MACRO (SYS::NAME SYS::LAMBDA-LIST SYS::BODY &OPTIONAL SYS::ENVIRONMENT)
  "This function is used to process a macro definition in the same way as DEFMACRO
and MACROLET.  It returns a lambda-expression that accepts two arguments (a 
form and an environment).  The NAME, LAMBDA-LIST,and BODY arguments correspond 
to the parts of a DEFMACRO or MACROLET definition."
  (DECLARE (IGNORE SYS::ENVIRONMENT))
  (WITH-STACK-LIST* (SYS::X SYS::NAME SYS::LAMBDA-LIST SYS::BODY)
     (SYS::MAKE-EXPANDER-FUNCTION SYS::X))) 



(EVAL-WHEN (COMPILE LOAD EVAL)
  (DEFUN SYS::DEFMACRO-&MUMBLE-CHEVEUX (SYS::PATTERN SYS::PATH SYS::STATE)
    (COND
      ((NULL SYS::PATTERN) (LIST 0 0 0))
      ((ATOM SYS::PATTERN)
       (IF (> SYS::STATE 1)
	 (FERROR NIL "Non-NIL end of list, ~S, following ~S in destructuring pattern."
		 SYS::PATTERN
		 (CASE SYS::STATE
		   (2 '&REST)
		   (3 '&AUX)
		   (4 '&KEY)
		   (T (IF (>= SYS::STATE 16)
			'&ENVIRONMENT
			'&LIST-OF))))
	 (SYS::DEFMACRO-CHEVEUX SYS::PATTERN SYS::PATH)
	 (LIST 0 0 NIL)))
      ((EQ (CAR SYS::PATTERN) '&OPTIONAL)
       (IF (> SYS::STATE 1)
	 (FERROR NIL "&OPTIONAL in bad context in destructuring pattern.")
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 1)))
      ((OR (EQ (CAR SYS::PATTERN) '&REST) (EQ (CAR SYS::PATTERN) '&BODY))
       (WHEN (EQ (CAR SYS::PATTERN) '&BODY)
	 (SETQ SYS::*DEFMACRO-&BODY-FLAG* T))
       (WHEN (NULL (CDR SYS::PATTERN))
	 (FERROR NIL "&REST or &BODY followed by no argument, in destructuring pattern."))
       (IF (> SYS::STATE 1)
	 (FERROR NIL "&REST or &BODY in bad context in destructuring pattern.")
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 2)))
      ((EQ (CAR SYS::PATTERN) '&AUX)
       (IF (>= SYS::STATE 8)
	 (FERROR NIL "&AUX following a &LIST-OF in destructuring pattern.")
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 3)))
      ((EQ (CAR SYS::PATTERN) '&KEY)
       (IF (> SYS::STATE 2)
	 (FERROR NIL "&KEY in bad context in destructuring pattern.")
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 4)))
      ((EQ (CAR SYS::PATTERN) '&ENVIRONMENT)
       (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH (+ SYS::STATE 16)))
      ((EQ (CAR SYS::PATTERN) '&LIST-OF)
       (IF (< SYS::STATE 3)
	 (PROGN
	   (COMPILER:CONFORMANCE-WARNING "~A" (CAR SYS::PATTERN))
	   (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH (+ 8 SYS::STATE)))
	 (FERROR NIL "&LIST-OF used incorrectly in destructuring pattern.")))
      ((EQ (CAR SYS::PATTERN) '&ALLOW-OTHER-KEYS)
       (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH SYS::STATE))
      ((= SYS::STATE 0) (SYS::DEFMACRO-CHEVEUX (CAR SYS::PATTERN) (LIST 'CAR SYS::PATH))
       (SYS::DEFMACRO-REQUIRED
	(SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) (LIST 'CDR SYS::PATH) 0)))
      ((= SYS::STATE 1)
       (IF (ATOM (CAR SYS::PATTERN))
	 (SYS::DEFMACRO-CHEVEUX (CAR SYS::PATTERN) `(CAR ,SYS::PATH))
	 (WHEN (CADDAR SYS::PATTERN)
	   (PUSH (CADDAR SYS::PATTERN) SYS::*OPTIONAL-SPECIFIED-FLAGS*))
	 (SYS::DEFMACRO-CHEVEUX (CAAR SYS::PATTERN)
				`(COND
				   (,SYS::PATH
				    ,(AND (CADDAR SYS::PATTERN) `(SETQ ,(CADDAR SYS::PATTERN) T))
				    (CAR ,SYS::PATH))
				   (T ,(CADAR SYS::PATTERN)))))
       (SYS::DEFMACRO-OPTIONAL
	(SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) (LIST 'CDR SYS::PATH) 1)))
      ((= SYS::STATE 2) (SYS::DEFMACRO-CHEVEUX (CAR SYS::PATTERN) SYS::PATH)
       (WHEN (CDR SYS::PATTERN)
	 (WHEN (OR (ATOM (CDR SYS::PATTERN))
	     (NOT (MEMBER (CADR SYS::PATTERN) '(&AUX &KEY &ENVIRONMENT))))
	   (FERROR NIL "More than one &REST argument in a macro."))
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 2))
       (LIST 0 0 NIL))
      ((= SYS::STATE 3)
       (IF (ATOM (CAR SYS::PATTERN))
	 (SYS::DEFMACRO-CHEVEUX (CAR SYS::PATTERN) NIL)
	 (SYS::DEFMACRO-CHEVEUX (CAAR SYS::PATTERN) (CADAR SYS::PATTERN)))
       (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) (LIST 'CDR SYS::PATH) 3))
      ((= SYS::STATE 4)
       (LET* ((SYMBOL
	       (COND
		 ((ATOM (CAR SYS::PATTERN)) (CAR SYS::PATTERN))
		 ((ATOM (CAAR SYS::PATTERN)) (CAAR SYS::PATTERN))
		 (T (CADAAR SYS::PATTERN))))
	      (KEYWORD
	       (IF (AND (CONSP (CAR SYS::PATTERN)) (CONSP (CAAR SYS::PATTERN)))
		 (CAAAR SYS::PATTERN)
		 (INTERN (STRING SYMBOL) 'KEYWORD)))
	      (SYS::DEFAULT (IF (CONSP (CAR SYS::PATTERN))
			      (CADAR SYS::PATTERN)
			      NIL))
	      (SYS::FLAGVAR (IF (CONSP (CAR SYS::PATTERN))
			      (CADDAR SYS::PATTERN))))
	 (PUSH SYMBOL SYS::*VARLIST*)
	 (PUSH `(GET (LOCF ,SYS::PATH) ',KEYWORD ,SYS::DEFAULT) SYS::*VALLIST*)
	 (WHEN SYS::FLAGVAR
	   (PUSH SYS::FLAGVAR SYS::*VARLIST*)
	   (PUSH `(NOT (NULL (SYS:GET-LOCATION-OR-NIL (LOCF ,SYS::PATH) ',KEYWORD)))
	      SYS::*VALLIST*))
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH 4)
	 (LIST 0 0 NIL)))
      ((= SYS::STATE 8) (SYS::DEFMACRO-&LIST-OF-CHEVEUX (CAR SYS::PATTERN) `(CAR ,SYS::PATH))
       (SYS::DEFMACRO-REQUIRED
	(SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) `(CDR ,SYS::PATH) 0)))
      ((= SYS::STATE 9)
       (WHEN (ATOM (CAR SYS::PATTERN))
	 (FERROR NIL "Incorrect use of &LIST-OF in destructuring pattern."))
       (WHEN (CADDAR SYS::PATTERN)
	 (PUSH (CADDAR SYS::PATTERN) SYS::*OPTIONAL-SPECIFIED-FLAGS*))
       (SYS::DEFMACRO-&LIST-OF-CHEVEUX (CAAR SYS::PATTERN)
				       `(COND
					  (,SYS::PATH
					   ,(WHEN (CADDAR SYS::PATTERN)
					      `(SETQ ,(CADDAR SYS::PATTERN) T))
					   (CAR ,SYS::PATH))
					  (T ,(CADAR SYS::PATTERN))))
       (SYS::DEFMACRO-OPTIONAL
	(SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) `(CDR ,SYS::PATH) 1)))
      ((= SYS::STATE 10) (SYS::DEFMACRO-&LIST-OF-CHEVEUX (CAR SYS::PATTERN) SYS::PATH)
       (WHEN (CDR SYS::PATTERN)
	 (WHEN (OR (ATOM (CDR SYS::PATTERN)) (NOT (EQ (CADR SYS::PATTERN) '&AUX)))
	   (FERROR NIL "More than one &REST argument in destructuring pattern."))
	 (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDDR SYS::PATTERN) SYS::PATH 3))
       (LIST 0 0 NIL))
      ((>= SYS::STATE 16) (SYS::DEFMACRO-CHEVEUX (CAR SYS::PATTERN) 'SYS::*MACROENVIRONMENT*)
       (SYS::DEFMACRO-&MUMBLE-CHEVEUX (CDR SYS::PATTERN) SYS::PATH (LOGAND SYS::STATE 15)))))
  (DEFUN SYS::DEFMACRO-&LIST-OF-CHEVEUX (SYS::PATTERN SYS::PATH)
    (SETQ SYS::*VALLIST*
	  (LET (SYS::*VALLIST*
		(SYS::VALS SYS::*VALLIST*))
	    (SYS::DEFMACRO-CHEVEUX SYS::PATTERN 'SYS::X)
	    (DO ((SYS::NVALS (NREVERSE SYS::*VALLIST*) (CDR SYS::NVALS))
		 (SYS::VALS SYS::VALS
		  (CONS `(MAPCAR #'(LAMBDA (SYS::X)
				     ,(CAR SYS::NVALS)) ,SYS::PATH) SYS::VALS)))
		((NULL SYS::NVALS)
		 SYS::VALS)))))
  (DEFUN SYS::DEFMACRO-CHEVEUX (SYS::PATTERN SYS::PATH)
    (COND
      ((NULL SYS::PATTERN))
      ((ATOM SYS::PATTERN)
       (WHEN (AND (SYMBOLP SYS::PATTERN) (= (CHAR (SYMBOL-NAME SYS::PATTERN) 0) #\&))
	 (IF (EQ SYS::PATTERN '&WHOLE)
	   (FERROR NIL "&WHOLE must appear first in a DEFMACRO lambda-list.")
	   (FERROR NIL "Unrecognized & keyword in DEFMACRO:  ~S." SYS::PATTERN)))
       (SETQ SYS::*VARLIST* (CONS SYS::PATTERN SYS::*VARLIST*)
	     SYS::*VALLIST* (CONS SYS::PATH SYS::*VALLIST*)))
      (T (SYS::DEFMACRO-&MUMBLE-CHEVEUX SYS::PATTERN SYS::PATH 0))))
  (DEFUN SYS::DEFMACRO-OPTIONAL (SYS::ARGS-DATA)
    (LIST (CAR SYS::ARGS-DATA) (1+ (CADR SYS::ARGS-DATA))
	  (IF (CADDR SYS::ARGS-DATA)
	    (1+ (CADDR SYS::ARGS-DATA))
	    NIL)))
  (DEFUN SYS::DEFMACRO-REQUIRED (SYS::ARGS-DATA)
    (LIST (1+ (CAR SYS::ARGS-DATA)) (CADR SYS::ARGS-DATA)
	  (IF (CADDR SYS::ARGS-DATA)
	    (1+ (CADDR SYS::ARGS-DATA))
	    NIL)))) 



))




#!C
; From file reader.LISP#> READER; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; READER.É#É"


(DEFUN SYS::READ-TOKEN (STREAM SYS::FIRSTCHAR)
  "This function is just an fsm that recognizes numbers and symbols."
  (DECLARE (INLINE SYS::FAST-CHAR-UPCASE))
  (IF *READ-SUPPRESS*
    (SYS::READ-EXTENDED-TOKEN-FOR-READ-SUPPRESS STREAM SYS::FIRSTCHAR)
    (LET ((SYS::ATTRIBUTE-TABLE (SYS::CHARACTER-ATTRIBUTE-TABLE *READTABLE*))
	  (SYS::PKG *PACKAGE*)
	  (SYS::COLONS 0))
      (SYS::RESET-READ-BUFFER)
      (PROG ((CHAR SYS::FIRSTCHAR))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (8 (GO SYS::SIGN))
	  (7 (GO SYS::LEFTDIGIT))
	  (5 (GO SYS::LEFTDIGIT))
	  (4 (GO SYS::FRONTDOT))
	  (2 (GO SYS::ESCAPE))
	  (11 (GO SYS::COLON))
	  (10 (GO SYS::MULT-ESCAPE))
	  (T (GO SYMBOL)))
	SYS::SIGN
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::LEFTDIGIT))
	  (5 (GO SYS::LEFTDIGIT))
	  (4 (GO SYS::SIGNDOT))
	  (2 (GO SYS::ESCAPE))
	  (11 (GO SYS::COLON))
	  (10 (GO SYS::MULT-ESCAPE))
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (T (GO SYMBOL)))
	SYS::LEFTDIGIT
	(UNLESS (DIGIT-CHAR-P CHAR (MAX 10 *READ-BASE*))
	  (GO SYMBOL))
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (RETURN (SYS::MAKE-INTEGER)))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::LEFTDIGIT))
	  (4 (GO SYS::MIDDLEDOT))
	  (5
	   (IF (DIGIT-CHAR-P CHAR (MAX *READ-BASE* 10))
	     (GO SYS::LEFTDIGIT)
	     (GO SYS::EXPONENT)))
	  (6 (GO RATIO))
	  (12 (UNREAD-CHAR CHAR STREAM) (RETURN (SYS::MAKE-INTEGER)))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::MIDDLEDOT
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (RETURN (LET ((*READ-BASE* 10))
		    (SYS::MAKE-INTEGER))))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RIGHTDIGIT))
	  (5 (GO SYS::EXPONENT))
	  (12 (UNREAD-CHAR CHAR STREAM) (RETURN (LET ((*READ-BASE* 10))
						  (SYS::MAKE-INTEGER))))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::RIGHTDIGIT
	(UNLESS (DIGIT-CHAR-P CHAR (MAX *READ-BASE* 10))
	  (GO SYMBOL))
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (RETURN (SYS::MAKE-FLOAT)))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RIGHTDIGIT))
	  (5 (GO SYS::EXPONENT))
	  (12 (UNREAD-CHAR CHAR STREAM) (RETURN (SYS::MAKE-FLOAT)))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::SIGNDOT
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RIGHTDIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (T (GO SYMBOL)))
	SYS::FRONTDOT
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Dot context error."))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RIGHTDIGIT))
	  (4 (GO SYS::DOTS))
	  (12 (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Dot context error."))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::EXPONENT
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (8 (GO SYS::EXPTSIGN))
	  (7 (GO SYS::EXPTDIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::EXPTSIGN
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::EXPTDIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::EXPTDIGIT
	(UNLESS (DIGIT-CHAR-P CHAR 10)
	  (GO SYMBOL))
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (RETURN (SYS::MAKE-FLOAT)))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::EXPTDIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (RETURN (SYS::MAKE-FLOAT)))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	RATIO
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RATIODIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::RATIODIGIT
	(UNLESS (DIGIT-CHAR-P CHAR (MAX *READ-BASE* 10))
	  (GO SYMBOL))
	(SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (RETURN (SYS::MAKE-RATIO)))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (7 (GO SYS::RATIODIGIT))
	  (12 (UNREAD-CHAR CHAR STREAM) (RETURN (SYS::MAKE-RATIO)))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::DOTS
	(SYS::OUCH-READ-BUFFER CHAR)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (IF (COMMON-LISP-ON-P)
	    (PROGN
	      (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Too many dots."))
	    (GO SYS::RETURN-SYMBOL)))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (4 (GO SYS::DOTS))
	  (12 (UNREAD-CHAR CHAR STREAM)
	   (IF (COMMON-LISP-ON-P)
	     (PROGN
	       (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Too many dots."))
	     (GO SYS::RETURN-SYMBOL)))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYMBOL
	(SYS::PREPARE-FOR-FAST-READ-CHAR STREAM
	   (PROG ()
	     SYS::SYMBOL-LOOP
	     (SYS::OUCH-READ-BUFFER (SYS::FAST-CHAR-UPCASE CHAR))
	     (SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	     (UNLESS CHAR
	       (GO SYS::RETURN-SYMBOL))
	     (CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	       (2 (SYS::DONE-WITH-FAST-READ-CHAR) (GO SYS::ESCAPE))
	       (12 (SYS::DONE-WITH-FAST-READ-CHAR) (UNREAD-CHAR CHAR STREAM)
		(GO SYS::RETURN-SYMBOL))
	       (10 (SYS::DONE-WITH-FAST-READ-CHAR) (GO SYS::MULT-ESCAPE))
	       (11 (SYS::DONE-WITH-FAST-READ-CHAR) (GO SYS::COLON))
	       (9
		(LET ((SYS::NEXT-CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL)))
		  (UNLESS SYS::NEXT-CHAR
		    (SYS::OUCH-READ-BUFFER CHAR)
		    (GO SYS::RETURN-SYMBOL))
		  (IF (EQL (SYS::CHAR-CLASS SYS::NEXT-CHAR SYS::ATTRIBUTE-TABLE) 11)
		    (PROGN
		      (SYS::DONE-WITH-FAST-READ-CHAR)
		      (GO SYS::COLON))
		    (PROGN
		      (UNREAD-CHAR SYS::NEXT-CHAR STREAM)
		      (GO SYS::SYMBOL-LOOP)))))
	       (T (GO SYS::SYMBOL-LOOP)))))
	SYS::ESCAPE
	(LET ((SYS::NEXTCHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL)))
	  (IF SYS::NEXTCHAR
	    (SYS::OUCH-READ-BUFFER SYS::NEXTCHAR)
	    (FERROR 'SYS:READ-END-OF-FILE "End-of-file after escape character.")))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::MULT-ESCAPE
	(DO ((CHAR (SYS::INTERNAL-READ-CHAR STREAM T) (SYS::INTERNAL-READ-CHAR STREAM T)))
	    ((SYS::MULTIPLE-ESCAPE-P CHAR))
	  (IF (SYS::ESCAPEP CHAR)
	    (SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM T)))
	  (SYS::OUCH-READ-BUFFER CHAR))
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (GO SYS::RETURN-SYMBOL))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (12 (UNREAD-CHAR CHAR STREAM) (GO SYS::RETURN-SYMBOL))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO SYS::COLON))
	  (T (GO SYMBOL)))
	SYS::COLON
	(COND
	  ((ZEROP SYS::COLONS) (SETQ SYS::COLONS 1))
	  (T
	   (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Too many colons in ~S"
		   (SYS::READ-BUFFER-TO-STRING))))
	(DO ((SYS::STR (SYS::READ-BUFFER-TO-STRING)))
	    ((SETQ SYS::PKG (FIND-PACKAGE SYS::STR)))
	  (SIGNAL-PROCEED-CASE
	   ((SYS::PKG-I) 'SYS:READ-PACKAGE-NOT-FOUND "Package ~s does not exist." SYS::STR)
	   (:NO-ACTION (SETF SYS::PKG *PACKAGE*) (RETURN))
	   (:NEW-NAME (SETQ SYS::STR (STRING-UPCASE SYS::PKG-I)))
	   (:CREATE-PACKAGE (OR (FIND-PACKAGE SYS::STR) (MAKE-PACKAGE SYS::STR)))))
	(SYS::RESET-READ-BUFFER)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (FERROR 'SYS:READ-END-OF-FILE "End of file encountered after reading a colon."))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (12 (UNREAD-CHAR CHAR STREAM)
	   (UNLESS SYS:*READ-ACCEPT-EXTENSIONS*
	     (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1
		     "Non-standard terminating character after a colon, ~S" CHAR))
	   (LET ((*PACKAGE* SYS::PKG))
	     (RETURN (READ-PRESERVING-WHITESPACE STREAM T NIL T))))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11 (GO INTERN))
	  (T (GO SYMBOL)))
	INTERN
	(SETQ SYS::COLONS 2)
	(SETQ CHAR (SYS::INTERNAL-READ-CHAR STREAM NIL NIL))
	(UNLESS CHAR
	  (FERROR 'SYS:READ-END-OF-FILE "End of file encountered after reading a colon."))
	(CASE (SYS::CHAR-CLASS CHAR SYS::ATTRIBUTE-TABLE)
	  (12 (UNREAD-CHAR CHAR STREAM)
	   (UNLESS SYS:*READ-ACCEPT-EXTENSIONS*
	     (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1
		     "Non-standard terminating character after a colon, ~S" CHAR))
	   (LET ((*PACKAGE* SYS::PKG))
	     (RETURN (READ-PRESERVING-WHITESPACE STREAM T NIL T))))
	  (2 (GO SYS::ESCAPE))
	  (10 (GO SYS::MULT-ESCAPE))
	  (11
	   (CERROR :NO-ACTION NIL 'SYS:READ-ERROR-1 "Too many colons after ~S:"
		   (PACKAGE-NAME SYS::PKG))
	   (GO INTERN))
	  (T (GO SYMBOL)))
	SYS::RETURN-SYMBOL
	(RETURN (SYS::READ-MAKE-SYMBOL SYS::COLONS SYS::PKG)))))) 


(DEFUN SYS::READ-MAKE-SYMBOL (SYS::COLONS SYS::PKG &AUX (SYS::L (LENGTH SYS::READ-BUFFER)))
  (UNWIND-PROTECT (BLOCK
		   NIL
		   (SETF (FILL-POINTER SYS::READ-BUFFER) SYS::OUCH-PTR)
		   (IF (OR (ZEROP SYS::COLONS)
		       (AND SYS:*READ-ACCEPT-EXTENSIONS* (NULL SYS::*RESTRICT-INTERNAL-SYMBOLS*))
		       (= SYS::COLONS 2) (EQ SYS::PKG *KEYWORD-PACKAGE*))
		     (RETURN
		      (LET ((SYS::R
			     (IF (AND (BOUNDP 'SYS::*READ-INTERN-FUNCTION*)
				 (FUNCTIONP SYS::*READ-INTERN-FUNCTION*))
			       (FUNCALL SYS::*READ-INTERN-FUNCTION* SYS::READ-BUFFER SYS::PKG)
			       (INTERN SYS::READ-BUFFER SYS::PKG))))
			(IF (AND (PLUSP SYS::COLONS) (EQ SYS::PKG (SYMBOL-PACKAGE SYS::R)))
			  SYS::R
			  (OR (CDR (ASSOC SYS::R SYS::*READER-SYMBOL-SUBSTITUTIONS* :TEST #'EQ))
			     SYS::R))))
		     (MULTIPLE-VALUE-BIND (SYMBOL SYS:TEST) (FIND-SYMBOL SYS::READ-BUFFER SYS::PKG)
		       (COND
			 ((EQ SYS:TEST :EXTERNAL)
			  (RETURN
			   (IF (EQ SYS::PKG (SYMBOL-PACKAGE SYMBOL))
			     SYMBOL
			     (OR
			      (CDR (ASSOC SYMBOL SYS::*READER-SYMBOL-SUBSTITUTIONS* :TEST #'EQ))
			      SYMBOL))))
			 ((NULL SYS:TEST)
			  (CERROR :MAKE-SYMBOL NIL 'SYS:READ-ERROR-1
				  "Symbol ~S not found in package ~S." SYS::READ-BUFFER
				  (PACKAGE-NAME SYS::PKG))
			  (RETURN (INTERN SYS::READ-BUFFER SYS::PKG)))
			 ((AND SYS::*RESTRICT-INTERNAL-SYMBOLS* (EQ SYS:TEST :INTERNAL)
			     (RASSOC SYMBOL SYS::*ZETALISP-SYMBOL-SUBSTITUTIONS* :TEST #'EQ))
			  (RETURN SYMBOL))
			 (T
			  (COMPILER::MINDEFS-WARN NIL :IMPLAUSIBLE
						  "The symbol ~S is not external in the package ~A."
						  SYMBOL (PACKAGE-NAME SYS::PKG))
			  (RETURN SYMBOL))))))
    (SETF (FILL-POINTER SYS::READ-BUFFER) SYS::L)))

;(eval-when (load )
; (setq secondary-attribute-table #.(init-secondary-attribute-table)) 
; (setq standard-readtable #.(init-std-zetalisp-readtable))
; (setq common-lisp-readtable #.(init-std-lisp-readtable)))

))

#!C
; From file functions.LISP#> READER; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* si:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; functions.É#É"

;; may 07/09/90 Added back the ticlos pkg to the with-slots symbol below
;; which fixes warning: "Misplaced declaration: (DECLARE (SPECIAL SYS::NAME SYS::SIZE SYS::INCLUDE ...))"
;; when compiling a function with the form: (using-defstruct-special-variables) as is in
;; the function sys:defstruct-get-type-description .
(DEFUN PARSE-BODY (SYS::BODY SYS::ENVIRONMENT &OPTIONAL (SYS::DOC-STRING-ALLOWED T))
  "This function is to parse the declarations and doc-string out
  of the body of a defun-like form.  Body is the list to be parsed and consists
  of everything after the formal parameter list.
  Environment is the lexical environment to expand macros in.  If
  Doc-String-Allowed is true, then a doc string will be parsed out of the body
  and returned.  If it is false then a string will terminate the search for
  declarations.  Three values are returned: the tail of Body after the
  declarations and doc strings, a list of declare forms, and the doc-string,
  or NIL if none."
  (DECLARE (VALUES SYS::BODY SYS::DECS SYS::DOC-STRING))
  (LET (SYS::DECLS
	SYS::DOC)
    (DO ((SYS::TAIL SYS::BODY (CDR SYS::TAIL)))
	((ENDP SYS::TAIL)
	 (VALUES SYS::TAIL (NREVERSE (THE LIST SYS::DECLS)) SYS::DOC))
      (LET ((SYS::FORM (CAR SYS::TAIL)))
	(COND
	  ((AND (STRINGP SYS::FORM) (CDR SYS::TAIL))
	   (IF SYS::DOC-STRING-ALLOWED
	     (SETQ SYS::DOC SYS::FORM)
	     (RETURN (VALUES SYS::TAIL (NREVERSE (THE LIST SYS::DECLS)) SYS::DOC))))
	  ((NOT (AND (CONSP SYS::FORM) (SYMBOLP (CAR SYS::FORM))))
	   (RETURN (VALUES SYS::TAIL (NREVERSE (THE LIST SYS::DECLS)) SYS::DOC)))
	  ((EQ (CAR SYS::FORM) 'DECLARE) (PUSH SYS::FORM SYS::DECLS))
	  ((OR
	    (LET ((SYS::PKG (SYMBOL-PACKAGE (CAR SYS::FORM))))
	      (OR (EQ SYS::PKG *LISP-PACKAGE*) (EQ SYS::PKG (SYMBOL-PACKAGE 'ticlos:WITH-SLOTS))))	;; may 07/09/90 
	    (EQ (CAR SYS::FORM) 'LOAD-TIME-VALUE))
	   (RETURN (VALUES SYS::TAIL (NREVERSE (THE LIST SYS::DECLS)) SYS::DOC)))
	  (T
	   (MULTIPLE-VALUE-BIND (SYS::RES SYS::WIN) (CATCH-ERROR (MACROEXPAND SYS::FORM SYS::ENVIRONMENT) NIL)
	     (IF (AND SYS::WIN (CONSP SYS::RES) (EQ (CAR SYS::RES) 'DECLARE))
	       (PROGN
		 (WHEN (EQ COMPILER:CHECK-CONFORMANCE ':ANSI)
		   (COMPILER:CONFORMANCE-WARNING "macro ~S expands into a DECLARE."
						 (CAR SYS::FORM)))
		 (PUSH SYS::RES SYS::DECLS))
	       (RETURN (VALUES SYS::TAIL (NREVERSE (THE LIST SYS::DECLS)) SYS::DOC))))))))))



))




