LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030430. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "ZETALISP" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758303281. :AUTHOR "REL3" :LENGTH-IN-BYTES 27964. :LENGTH-IN-BLOCKS 28. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          ;;; -*- Mode:Common-Lisp; Package:Compiler2; Base:10 -*-;;;;;;      RESTRICTED RIGHTS LEGEND;;;;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;TEXAS INSTRUMENTS INCORPORATED.;;; P.O. BOX 2909;;;      AUSTIN, TEXAS 78769;;;    MS 2151;;;; Copyright (C) 1980 Massachusetts Institute of Technology; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;;;   *-----------------------------------------------------------*;;;;   |           --  TI Explorer Lisp Compiler  --               |;;;;   |  This file contains portions of the compiler that are     |;;;;   |  concerned with supporting compatibility with Zetalisp.   |;;;;   |  If only pure Common Lisp code is to be supported, then   |;;;;   |  this file does not need to be loaded.   |;;;;   *-----------------------------------------------------------*;;;;;;;  2/25/86 DNG - Original; moved some things to here from files P1STYLE and P1OPT.;;;  4/06/86 DNG - Converted from Zetalisp to Common Lisp.;;;  4/24/86 DNG - Add warnings for ARGS-INFO and DEBUGGING-INFO.;;;  6/05/86 DNG - Add handling for obsolete OPEN options.;;;  6/21/86 DNG - Eliminated use of MEMQ.;;;  8/08/86 DNG - Moved DEFUN-COMPATIBILITY to here from FILE.;;;  9/20/86 DNG - Moved P1SUBSET to here from P1HAND.;;;  9/30/86 DNG - Moved QC-FILE-LOAD here from FILE.;;; 12/09/86 DNG - Change status of ADJUST-ARRAY-SIZE from obsolete to;;;superseded since it is still used internally.;;;Permit MAKE-ARRAY with :TYPE option in kernel files.;;;  1/21/87 DNG - Give warning on %ARGS-INFO .;;;  1/30/87 DNG - Update MAKE-ARRAY-STYLE for SINGLE-FLOAT/DOUBLE-FLOAT distinction.;;;  4/08/87 DNG - Delete obsolete warnings for GLOBAL:CATCH and GLOBAL:THROW.;;;;    ==================================;;;;   Definition of obsolete compiler functions;;;;    ==================================(DEFUN QC-FILE-LOAD (&REST QC-FILE-ARGS)  "Compile a file and then load the binary file."  (DECLARE (ARGLIST (INPUT-FILE &OPTIONAL OUTPUT-FILE)))  (LOAD (APPLY #'QC-FILE QC-FILE-ARGS)));;;;    ==================================;;;;   Optimizers to correct obsolete usage;;;;    ==================================(ADD-OPTIMIZER DEFUN FIX-DEFUN)(DEFUN FIX-DEFUN (FORM)  ;;  8/09/86 DNG - Original. [previously done in COMPILE-DRIVER]  (LET (TEM)    (WARN-ON-ERRORS ('MALFORMED-DEFUN "Malformed DEFUN: ~S" FORM)      (SETQ TEM (DEFUN-COMPATIBILITY (CDR FORM))))    (IF (EQ (CDR TEM) (CDR FORM))FORM      (PROGN(WHEN (COMMON-LISP-ON-P)  (LET (( SI:WARNINGS-PRINLENGTH 3)( SI:WARNINGS-PRINLEVEL 2))    (WARN 'DEFUN-COMPATIBILITY ':OBSOLETE  "Obsolete DEFUN syntax: ~S~%The new way is: ~S"  FORM TEM ) ) )TEM ))))(DEFUN DEFUN-COMPATIBILITY (EXP)  "Process the cdr of a DEFUN-form, converting old Maclisp formats into modern Lispm ones.This must be done before the name of the function can be determined with certainty.The value is an entire form, starting with DEFUN or MACRO.If no change has been made, the cdr of the value will be EQ to the argument."  ;; 08/09/86 DNG - Use STRING-EQUAL to compare for FEXPR or EXPR since these symbols won't be global.  (PROG (FCTN-NAME LL BODY TYPE TM)(SETQ TYPE 'EXPR)(SETQ FCTN-NAME (CAR EXP))(COND ((NOT (ATOM FCTN-NAME));Convert list function specs       (COND ((AND (= (LENGTH FCTN-NAME) 2);(DEFUN (FOO MACRO) ...)   (EQ (SECOND FCTN-NAME) 'MACRO))      (SETQ TYPE 'MACRO FCTN-NAME (CAR FCTN-NAME)))     ((EQ FCTN-NAME (SETQ FCTN-NAME (STANDARDIZE-FUNCTION-SPEC FCTN-NAME)))      (RETURN (CONS 'DEFUN EXP)))));Return if no conversion required      ((OR (NOT (ATOM (CADR EXP))) (NULL (CADR EXP))) ;Detect a valid DEFUN.       (RETURN (CONS 'DEFUN EXP)))      ((SETQ TM (MEMBER (CADR EXP) '(FEXPR EXPR MACRO) :TEST #'STRING-EQUAL))       (SETQ TYPE (CAR TM) EXP (CDR EXP)))      ((SETQ TM (MEMBER FCTN-NAME '(FEXPR EXPR MACRO) :TEST #'STRING-EQUAL))       (SETQ TYPE (CAR TM) FCTN-NAME (CADR EXP) EXP (CDR EXP))));; Here if a new DEFUN has to be constructed(SETQ LL (CADR EXP))(SETQ BODY (CDDR EXP));WEIRD CONVERSION HACK TO UNCONVERT INTERLISP NLAMBDAS THAT WERE PREVIOUSLY CONVERTED; BY HOLLOWAY'S RANDOM HACKER TO KLUDGY FEXPR'S(COND ((AND (EQ TYPE 'FEXPR)    (EQUAL LL '(*ARGS*)))(SETQ TYPE 'EXPR)(SETQ LL (CONS '&QUOTE (CADAAR BODY)))  ;LAMBDA LIST OF INTERNAL LAMBDA(SETQ BODY (CDDAAR BODY)) ));BODY OF INTERNAL LAMBDA; **END OF THAT HACK**(COND ((EQ TYPE 'FEXPR)       (SETQ LL (CONS '&QUOTE (CONS '&REST LL))))      ((EQ TYPE 'MACRO)       (RETURN (CONS 'MACRO (CONS FCTN-NAME (CONS LL BODY)))))      ((AND LL (ATOM LL))(SETQ TYPE 'LEXPR     LL `(&EVAL &REST *LEXPR-ARGLIST* &AUX (,LL (LENGTH *LEXPR-ARGLIST*))))))(RETURN (CONS 'DEFUN (CONS FCTN-NAME (CONS LL BODY))))))(ADD-OPTIMIZER BREAK BREAK-CHECK)(DEFUN BREAK-CHECK (FORM)  ;; Convert old-style Zetalisp BREAK.  ;;  4/30/85 - Original. (Warning previously given by a style checker.)  (LET (( NAME (CADR-SAFE FORM) ))    (IF (AND (NOT (NULL NAME))     (SYMBOLP NAME)     (NOT COMPILING-COMMON-LISP)     (NOT (LOOKUP-VAR NAME VARS))   )(PROGN  (UNLESS INHIBIT-STYLE-WARNINGS-SWITCH    (WARN 'BREAK-ARG ':OBSOLETE  "A symbol as the first argument to BREAK is an obsolete construct;change it to a string before it stops working.") )  (LIST* (FIRST FORM) (SYMBOL-NAME NAME) (CDDR FORM)) )      FORM ) ) )(ADD-OPTIMIZER MAKE-LIST OLD-MAKE-LIST)(DEFUN OLD-MAKE-LIST (FORM)  ;;  2/25/86 DNG - Original; separated from MAKE-LIST-%MAKE-LIST.  (IF (= (LENGTH FORM) 3)      ;; It is old-style.      (PROGN(WHEN (AND OBSOLETE-FUNCTION-WARNING-SWITCH   (NOT INHIBIT-STYLE-WARNINGS-SWITCH))  (LET ((SI:WARNINGS-PRINLEVEL 2))    (WARN 'MAKE-LIST :OBSOLETE  "Obsolete usage: ~S; use ~S instead."  FORM  (IF (MEMBER (SECOND FORM) '(NIL (QUOTE NIL) DEFAULT-CONS-AREA) :TEST #'EQUAL)       `(MAKE-LIST ,(THIRD FORM))    `(MAKE-LIST ,(THIRD FORM) :AREA ,(SECOND FORM)) ))))`(%MAKE-LIST 'NIL ,(SECOND FORM) ,(THIRD FORM) ))    FORM ));;Optimize (EQ (TYPEP ...) 'SYMBOL), etc.(ADD-OPTIMIZER EQ EQ-TYPEP)(DEFUN EQ-TYPEP (FORM)  (BLOCK NIL      (AND (NOT (ATOM (CADR FORM)))   (NOT (ATOM (CADDR FORM)))   (COND ((AND (MEMBER (CAADR FORM) '(TYPEP TYPE-OF))       (NULL (CDDADR FORM))  ;Check that TYPEP has only one arg!       (EQ (CAADDR FORM) 'QUOTE))  (RETURN (EQ-TYPEP-1 (CADADR FORM) (CADR (CADDR FORM)) FORM))) ((AND (EQ (CAADR FORM) 'QUOTE)       (MEMBER (CAADDR FORM) '(TYPEP TYPE-OF))       (NULL (CDDR (CADDR FORM))))  (RETURN (EQ-TYPEP-1 (CADR (CADDR FORM)) (CADADR FORM) FORM)))))      (RETURN FORM)))(DEFUN EQ-TYPEP-1 (FORM TYPE TOPFORM &aux pred)  ;; 12/20/85 DNG - Added obsolete warning.  (UNLESS INHIBIT-STYLE-WARNINGS-SWITCH     (WARN 'EQ-TYPEP :OBSOLETE "~A is an obsolete construct; use: ~A"  TOPFORM   `(TYPEP ,FORM ',TYPE)) )  (SETQ PRED (OR (CAR (RASSOC TYPE '((STRINGP . CLI:STRING) (SYMBOLP . SYMBOL) (CONSP . LIST)     (STRINGP . :STRING) (SYMBOLP . :SYMBOL) (GLOBAL:LISTP . :LIST)     (STRINGP . GLOBAL:STRING))      :TEST #'EQ)) (CAR (RASSOC TYPE SI:TYPEP-ONE-ARG-ALIST :TEST #'EQUAL)) (CAR (RASSOC TYPE SI:TYPE-OF-ALIST :TEST #'EQUAL))))  (COND ((NULL PRED) TOPFORM)((NUMBERP PRED) `(= (%DATA-TYPE ,FORM) ,PRED))((SYMBOLP PRED) `(,PRED ,FORM))(T TOPFORM)));By special dispensation, VALUE-CELL-LOCATION of a quoted symbol;gets the location of any sort of variable; but this is obsolete.(ADD-OPTIMIZER VALUE-CELL-LOCATION V-C-L-FIX)(DEFUN V-C-L-FIX (FORM)  ;; 10/17/86 DNG - Original; code taken from style checker and pass 1 handler.  (LET ((ARG (SECOND FORM)))    (IF (AND (NOT (ATOM ARG))     (EQ (CAR ARG) 'QUOTE))(LET ((VAR (SECOND ARG)))  (COND ((NOT (SYMBOLP VAR)) (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE       "The argument of VALUE-CELL-LOCATION is '~S." VAR) NIL)((SPECIALP VAR) FORM)(T (LET ((NEW `(VARIABLE-LOCATION ,VAR)))     (UNLESS INHIBIT-STYLE-WARNINGS-SWITCH       (WARN 'VALUE-CELL-LOCATION :OBSOLETE     "~S is obsolete; use ~S)."     FORM NEW))     NEW))))      FORM)))(ADD-OPTIMIZER BOUNDP BOUNDP-FIX)(DEFUN BOUNDP-FIX (FORM)  ;; 10/17/86 DNG - Original; code taken from style checker and pass 1 handler.  (LET ((ARG (SECOND FORM)))    (IF (AND (QUOTEP ARG)     (NOT COMPILING-COMMON-LISP)     (SYMBOLP (SECOND ARG)))(PROGN  (UNLESS (OR (SPECIALP (SECOND ARG))      INHIBIT-STYLE-WARNINGS-SWITCH      (NOT OBSOLETE-FUNCTION-WARNING-SWITCH))    (WARN 'BOUNDP :OBSOLETE  "BOUNDP of a quoted nonspecial variable is obsolete; use VARIABLE-BOUNDP"))  `(VARIABLE-BOUNDP ,(SECOND ARG)))      FORM)));; For compatibility with Maclisp and early versions of Zetalisp [as in MIT ;; "Lisp Machine Manual" 4th edition, 1981], the OPEN function used to accept ;; an option name or a list of options (a single arg), as an alternative to ;; keywords and values.  These option names could be in any package.  This is ;; no longer supported by the Explorer release 3 version of OPEN, so the ;; following optimizer is used to convert obsolete calls and warn the user.(ADD-OPTIMIZER OPEN OBSOLETE-OPEN)(DEFUN OBSOLETE-OPEN (FORM)  ;;  6/05/86 - Original version, adapted from code in the release 2 OPEN function.  (IF (AND (= (LENGTH FORM) 3)   (CONSTANTP (THIRD FORM)))      (LET (( OPTIONS (SI:EVAL (THIRD FORM)) )    ( NEW-OPTIONS NIL ))(WHEN (ATOM OPTIONS)  (SETQ OPTIONS (LIST OPTIONS)))(DO ((KEYL OPTIONS (CDR KEYL))     (KEY)     (CHARACTERS T)     (DIRECTION :INPUT)     (BYTE-SIZE NIL)     (ERROR-P T)     (ERROR-P-SPECD NIL)     (DELETED-P NIL)     (TEMPORARY-P NIL)     ;; These two are really only useful for machines that do not natively store     ;; 8-bit characters.     (RAW-P NIL)     (SUPER-IMAGE-P NIL)     )    ((NULL KEYL)     (WHEN RAW-P  (SETQ NEW-OPTIONS (LIST* :RAW  RAW-P NEW-OPTIONS)))     (WHEN SUPER-IMAGE-P  (SETQ NEW-OPTIONS (LIST* :SUPER-IMAGE  SUPER-IMAGE-P NEW-OPTIONS)))     (WHEN TEMPORARY-P    (SETQ NEW-OPTIONS (LIST* :TEMPORARY  TEMPORARY-P NEW-OPTIONS)))     (WHEN DELETED-P      (SETQ NEW-OPTIONS (LIST* :DELETED  DELETED-P NEW-OPTIONS)))     (WHEN ERROR-P-SPECD  (SETQ NEW-OPTIONS (LIST* :ERROR  ERROR-P NEW-OPTIONS)))     (WHEN BYTE-SIZE (SETQ NEW-OPTIONS (LIST* :BYTE-SIZE BYTE-SIZE NEW-OPTIONS)))     (SETQ NEW-OPTIONS (LIST* :CHARACTERS CHARACTERS :DIRECTION DIRECTION NEW-OPTIONS)))  (SETQ KEY (CAR KEYL))  (SELECTOR KEY STRING-EQUAL ; must use STRING-EQUAL because MacLisp doesn't have packages.    ((:IN :READ) (SETQ DIRECTION :INPUT))    ((:OUT :WRITE :PRINT) (SETQ DIRECTION :OUTPUT))    ((:BINARY :FIXNUM) (SETQ CHARACTERS NIL))    ((:CHARACTER :ASCII) (SETQ CHARACTERS T))    ((:BYTE-SIZE) (SETQ KEYL (CDR KEYL)BYTE-SIZE (CAR KEYL)))    ((:PROBE) (SETQ DIRECTION NIL    CHARACTERS NIL    ERROR-P-SPECD T    ERROR-P NIL))    ((:NOERROR) (SETQ ERROR-P NIL ERROR-P-SPECD T))    ((:ERROR) (SETQ ERROR-P T ERROR-P-SPECD T))    ((:RAW) (SETQ RAW-P T))    ((:SUPER-IMAGE) (SETQ SUPER-IMAGE-P T))    ((:DELETED) (SETQ DELETED-P T))    ((:TEMPORARY) (SETQ TEMPORARY-P T))    ((:BLOCK :SINGLE) );Ignored for compatility with Maclisp    (OTHERWISE (WARN 'OBSOLETE-OPEN :IMPOSSIBLE      "~S is not a known OPEN option." KEY)       (WHEN (EQL (LENGTH OPTIONS) 1) ;; If the only option is bad, can't meaningfully convert. (RETURN-FROM OBSOLETE-OPEN FORM)))))(LET (( NEW-FORM (LIST* (FIRST FORM) (SECOND FORM) NEW-OPTIONS) ))  (WHEN (AND OBSOLETE-FUNCTION-WARNING-SWITCH     (OR COMPILING-COMMON-LISP (NOT INHIBIT-STYLE-WARNINGS-SWITCH)))    (LET ((SI:WARNINGS-PRINLENGTH 20)  (SI:WARNINGS-PRINLEVEL 3))      (WARN 'OBSOLETE-OPEN :VERY-OBSOLETE    "Obsolete options in: ~S~%use ~S instead." FORM NEW-FORM)))  NEW-FORM))    FORM));;;;    ==================================;;;;    Optimization of obsolete functions;;;;    ==================================;; We might ought to just delete the following, since GET-FROM-ALTERNATING-LIST;; has been flagged as obsolete since Explorer release 1.0.(ADD-OPTIMIZER GET-FROM-ALTERNATING-LIST GFAL-GET)(DEFUN GFAL-GET (X)  (IF (OR (SYMBOLP (CADR X))  (AND (CONSP (CADR X))       (DO ((FORM1 (CADR X)))   (NIL) (AND (OR (GET (CAR FORM1) 'LOCF) (GET (CAR FORM1) 'SI:SETF-EXPANDER))      (RETURN T)) (AND (EQ FORM1 (SETQ FORM1 (MACROEXPAND-1 FORM1)))      (RETURN NIL)))))      `(GET (LOCF ,(CADR X)) ,@(CDDR X))    X))(ADD-OPTIMIZER ADD1 ADD1-FIX)(ADD-OPTIMIZER SUB1 ADD1-FIX)(DEFUN ADD1-FIX (FORM)  (CONS (TRANSLATED-FUNCTION FORM '((ADD1 . 1+)  (SUB1 . 1-)))(CDR FORM)))(DEFCOMPILER-SYNONYM PLUS+)(DEFCOMPILER-SYNONYM TIMES*)(DEFCOMPILER-SYNONYM DIFFERENCE-)(DEFCOMPILER-SYNONYM \\REMAINDER)(ADD-POST-OPTIMIZER FIX FOLD-ONE-ARG)(ADD-POST-OPTIMIZER DEPOSIT-BYTE ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER LOAD-BYTE ARITH-OPT-NON-ASSOCIATIVE)(EVAL-WHEN ( EVAL LOAD )  ;; Let it be known that these functions have no side-effects.  (DOLIST ( F '( GLOBAL:/ GLOBAL:AREF GLOBAL:AR-1 GET-PNAME SYMEVAL FSYMEVAL))    (WHEN (NULL (GET F 'P1))      (SETF (GET F 'P1) 'P1SIMPLE) ) ) )(DEFPROP SUBSETP1SUBSET P1)(DEFPROP SUBSET-NOTP1SUBSET P1)(DEFUN P1SUBSET (FORM) ;;  1/29/86 Use CONS instead of NCONS to avoid warning. ;;  8/15/86 Optimizer SUBSET-EXPAND changed to a P1 handler and renamed P1SUBSET. ;;  9/20/86 When speed>space, expand even when function is not a lambda expression.  (LET ((FN (PRE-OPTIMIZE (CADR FORM) NIL))PREDARGSDOCLAUSESTEM)    (COND      ((NOT OPEN-CODE-MAP-SWITCH) (P1-DOWNWARD-FUNARG FORM))      ;; Expand only if specified function is a quoted LAMBDA or a SUBST,      ;; or if speed is more important than space.      ((NOT (OR (AND (NOT (ATOM FN))     (MEMBER (CAR FN) '(QUOTE FUNCTION) :TEST #'EQ)     (OR (NOT (ATOM (CADR FN))) (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE OPTIMIZE-SWITCH))))(AND (NOT (ATOM FN))     (EQ (CAR FN) 'FUNCTION)     (NOT (ATOM (SETQ TEM (DECLARED-DEFINITION (CADR FN)))))     (MEMBER (CAR TEM)     '(GLOBAL:SUBST GLOBAL:NAMED-SUBST       SUBST NAMED-SUBST MACRO)     :TEST #'EQ))))       (P1-DOWNWARD-FUNARG FORM))      (T (SETQ FN (CADR FN));Strip off the QUOTE or FUNCTION. ;; Generate N local variable names.       (DO ((L (CDDR FORM) (CDR L))    (I 0 (1+ I)))   ((NULL L)) (LET ((V (INTERN (FORMAT NIL "MAP-LOCAL-~D" I))))   (PUSH `(,V ,(CAR L) (CDR ,V)) DOCLAUSES)   (PUSH `(CAR ,V) PREDARGS)))       (SETQ DOCLAUSES (NREVERSE DOCLAUSES)     PREDARGS (NREVERSE PREDARGS))       (P1 `(LET (MAP-RESULT)      (INHIBIT-STYLE-WARNINGS(DO-NAMED T  ((MAP-TEMP (INHIBIT-STYLE-WARNINGS (VARIABLE-LOCATION MAP-RESULT)))   . ,DOCLAUSES)  ((NULL ,(CAAR DOCLAUSES)))  (,(IF (MEMBER (CAR FORM) '(SUBSET) :TEST #'EQ)'AND      'OR)   (,FN . ,PREDARGS)   (RPLACD MAP-TEMP (SETQ MAP-TEMP (CONS ,(CAR PREDARGS) NIL))))))      MAP-RESULT))))));;;;    ==================================;;;;       Obsolete function warnings;;;;    ==================================;;;   ---  Old MacLisp functions  ---(MAKE-OBSOLETE ASCII "use strings")(MAKE-OBSOLETE GETCHAR "use strings")(MAKE-OBSOLETE GETCHARN "use strings")(MAKE-OBSOLETE IMPLODE "use strings")(MAKE-OBSOLETE MAKNAM "use strings")(MAKE-OBSOLETE EXPLODE "use strings")(MAKE-OBSOLETE EXPLODEC "use strings")(MAKE-OBSOLETE EXPLODEN "use strings")(MAKE-OBSOLETE SAMEPNAMEP "use strings")(MAKE-OBSOLETE READCH "use strings");; MacLisp array functions(MAKE-OBSOLETE ARRAY   MAKE-ARRAY)(MAKE-OBSOLETE *ARRAY  MAKE-ARRAY)(MAKE-OBSOLETE STORE   SETF)(MAKE-OBSOLETE XSTORE  NIL)(MAKE-OBSOLETE ARRAYCALL AREF)(MAKE-OBSOLETE ARRAYDIMS "use ARRAY-TYPE and ARRAY-DIMENSIONS instead")(MAKE-OBSOLETE GLOBAL:*LEXPR COMPILER:COMPILATION-DEFINE)(MAKE-OBSOLETE GLOBAL:*EXPR  COMPILER:COMPILATION-DEFINE)(MAKE-OBSOLETE GLOBAL:*FEXPR NIL) ; no exact equivalent exists(MAKE-OBSOLETE CASEQ CASE)(MAKE-OBSOLETE SIGNP "use <, >, or =")(MAKE-OBSOLETE ERR "use ERROR or FERROR");;;   ---  Obsolete Zetalisp functions  ---;;This can't go in PROCES because it gets loaded before this file(MAKE-OBSOLETE PROCESS-CREATE MAKE-PROCESS)(MAKE-OBSOLETE SI:PROCESS-RUN-TEMPORARY-FUNCTION PROCESS-RUN-FUNCTION)(MAKE-OBSOLETE FS:FILE-READ-PROPERTY-LIST FS:READ-ATTRIBUTE-LIST)(MAKE-OBSOLETE FS:FILE-PROPERTY-LIST FS:FILE-ATTRIBUTE-LIST)(MAKE-OBSOLETE FS:FILE-PROPERTY-BINDINGS FS:FILE-ATTRIBUTE-BINDINGS)(MAKE-OBSOLETE PRINT-LOADED-BAND PRINT-HERALD)(MAKE-OBSOLETE SI:WITH-RESOURCE USING-RESOURCE)(MAKE-OBSOLETE SI:CLOSURE-COPY COPY-CLOSURE)(MAKE-OBSOLETE ENTITY "use flavors") ; DTP-ENTITY will be eliminated in Explorer release 3.;; Note: the UNIMPLEMENTED style checking that used to be here has;; been deleted 1/21/86 because none of those symbols are even in ;; the GLOBAL package anymore.;; A(make-superseded add11+)(make-superseded adjust-array-size "see ADJUST-ARRAY")(make-obsolete global:ar-1 global:AREF)(make-obsolete CLI:ar-1       CLI:AREF)(make-obsolete ar-2         "use AREF instead") ; either GLOBAL:AREF or CLI:AREF(make-obsolete ar-2-reverse "use AREF and swap the index arguments")(make-obsolete ar-3         "use AREF instead") ; either GLOBAL:AREF or CLI:AREF(make-obsolete as-1         "use (SETF (AREF ...)) instead")(make-obsolete as-2         "use (SETF (AREF ...)) instead")(make-obsolete as-2-reverse "use (SETF (AREF a iv ih) val) instead of (AS-2-REVERSE val a ih iv)")(make-obsolete as-3         "use (SETF (AREF ...)) instead")(make-obsolete array-grow   ADJUST-ARRAY);; C;; D(make-superseded defunp "use DEFUN and RETURN-FROM")(make-obsolete deposit-byte "use (DPB v (BYTE s p) n) instead of (DEPOSIT-BYTE n p s v)")(make-superseded difference    -);; F(make-obsolete fix           FLOOR)(make-obsolete fixr     ROUND)(add-style-checker funcall-self semi-obsolete)(defun semi-obsolete (form) ; obsolete, but tolerated in Zetalisp mode.  (when (and COMPILING-COMMON-LISP     OBSOLETE-FUNCTION-WARNING-SWITCH )    (warn 'semi-obsolete :obsolete  "~S is an obsolete function; use ~A instead."  (first form)  (case (first form)     ( funcall-self "(SEND SELF ...)")     ( lexpr-funcall-self "(LEXPR-SEND SELF ...)")    ))))(make-obsolete si:function-documentation documentation);; G(make-superseded greaterp>);; L(make-superseded lessp<)(add-style-checker lexpr-funcall-self semi-obsolete)(make-obsolete load-byte "use (LDB (BYTE s p) n) instead of (LOAD-BYTE n p s)");; M(make-superseded minus-);; N;(make-obsolete ncons-in-area "use (CONS-IN-AREA x NIL a) instead")(make-superseded global:nlistp ATOM)  ;; P(make-superseded plus+);; Q;; R;; S#+compiler:debug(make-obsolete sassoc       "use (UNLESS (ASSOC ... :TEST #'EQUAL) (FUNCALL func)) instead")#+compiler:debug(make-obsolete sassq       "use (UNLESS (ASSOC ... :TEST #'EQ) (FUNCALL func)) instead")(make-obsolete setplist "use (SETF (SYMBOL-PLIST #) #)")(make-superseded sub11-);; T(make-superseded times*);; X;(make-obsolete xcons "use CONS with the arguments swapped")(make-obsolete xcons-in-area "use CONS-IN-AREA with the arguments swapped");; Numbers, Signs, & Symbols(make-superseded 1+$1+)(make-superseded 1-$1-)(make-superseded +$+)(make-superseded -$-)(make-superseded *$*)(make-obsolete *dif-)(make-obsolete *plus+)(make-obsolete *quoQUOTIENT)(make-obsolete *times*)(make-superseded ^$EXPT)(add-style-checker /$ obsolete-in-cl)(defprop /$ QUOTIENT superseded-by)(ADD-STYLE-CHECKER PROG OBSOLETE-PROG)(DEFUN OBSOLETE-PROG ( FORM )  ;;  1/31/86 - Original.  ;;  2/07/86 - Warn about all named PROGs.  ;;  3/19/86 - (BLOCK ~S ... NIL)  (WHEN COMPILING-COMMON-LISP    (LET (( NAME NIL ) LL BODY )      (COND ((LISTP (SECOND FORM))     (SETQ LL (SECOND FORM)   BODY (CDDR FORM)))    ((SYMBOLP (SECOND FORM))     (SETQ NAME (SECOND FORM)   LL (THIRD FORM)   BODY (NTHCDR 3 FORM)))    (T (RETURN-FROM OBSOLETE-PROG NIL)))      (IF (AND (NULL LL)       (CLI:EVERY #'CONSP (THE LIST BODY)) )  (WARN 'OBSOLETE-PROG :OBSOLETE"(PROG ~S ...) without any tags is obsolete; use (BLOCK ~S ... NIL) instead."(SECOND FORM) NAME )(UNLESS (NULL NAME)  (LET (( SI:WARNINGS-PRINLEVEL 2 )( SI:WARNINGS-PRINLENGTH 2 ))    (WARN 'OBSOLETE-PROG :OBSOLETE  "(PROG ~S ~S ...) is obsolete; use (BLOCK ~S (PROG ~S ...))."  NAME LL NAME LL)))  ))));;;   ---  Functions that became obsolete in Explorer release 3  ---#+Elroy(MAKE-OBSOLETE GLOBAL:ARGS-INFO  "ARGS-DESC is a quicker way to obtain similar information")#+Elroy(MAKE-OBSOLETE %ARGS-INFO  "ARGS-DESC is a quicker way to obtain similar information")#+Elroy(MAKE-OBSOLETE GLOBAL:DEBUGGING-INFO  "see GET-DEBUG-INFO-STRUCT and GET-DEBUG-INFO-FIELD")#-Elroy ; temporary for cross-compiling(PROGN(ADD-STYLE-CHECKER ARGS-INFO ARGS-INFO-STYLE)(ADD-STYLE-CHECKER %ARGS-INFO ARGS-INFO-STYLE)(DEFUN ARGS-INFO-STYLE ( FORM )  ;;  4/24/86 DNG - Original.  (WHEN (AND (COMPILING-FOR-V2)     (NOT (ZEROP 1-IF-LIVE-CODE)))    (WARN 'ARGS-INFO :OBSOLETE  "~S is obsolete in VM2; use ~S instead."  (FIRST FORM) 'SI:ARGS-DESC) ))(ADD-STYLE-CHECKER  GLOBAL:DEBUGGING-INFO DBI-STYLE)(DEFUN DBI-STYLE ( FORM )  ;;  4/24/86 DNG - Original.  (WHEN (AND (COMPILING-FOR-V2)     (NOT (ZEROP 1-IF-LIVE-CODE)))    (WARN 'DEBUGGING-INFO :OBSOLETE  "~S is obsolete in VM2; see ~S and ~S."  (FIRST FORM) 'SI:GET-DEBUG-INFO-STRUCT 'SI:GET-DEBUG-INFO-FIELD) ))(ADD-STYLE-CHECKER GLOBALIZE GLOBALIZE-STYLE)(DEFUN GLOBALIZE-STYLE ( FORM )  ;;  7/22/86 DNG - Original.  (WHEN (AND (COMPILING-FOR-V2)     (NOT (ZEROP 1-IF-LIVE-CODE)))    (WARN 'GLOBALIZE-STYLE :VERY-OBSOLETE  "~S is not supported in release 3; the nearest equivalent is ~S."  (FIRST FORM)  `(EXPORT ,(SECOND FORM) ,(OR (THIRD FORM) "GLOBAL")) )))) ; end of not Elroy;;;   ---  Obsolete usage of function arguments  ---(ADD-STYLE-CHECKER MAKE-ARRAY MAKE-ARRAY-STYLE)(DEFUN MAKE-ARRAY-STYLE ( FORM )  ;;  2/04/86 - Original.  ;; 12/09/86 - Permit :TYPE option in kernel files.  ;;  1/30/87 - Update for SINGLE-FLOAT/DOUBLE-FLOAT distinction.  (LET (( DIMENSIONS (SECOND FORM) )( OPTIONS (CDDR FORM) ))    (IF (AND (>= (LENGTH OPTIONS) 2)     (OR (NUMBERP (FIRST OPTIONS)) (LET ( FIRST-OPT )   (AND (QUOTEP (FIRST OPTIONS))(SETQ FIRST-OPT (SECOND (FIRST OPTIONS)))(OR (MEMBER FIRST-OPT SI:ARRAY-TYPES :TEST #'EQ)     (MEMBER FIRST-OPT SI:ARRAY-TYPE-KEYWORDS :TEST #'EQ)))) (AND (NOT (KEYWORDP (FIRST OPTIONS)))      (ODDP (LENGTH OPTIONS)))));; It is old-style.  The first arg is actually AREA.(LET (( AREA DIMENSIONS )      ( TYPE (FIRST OPTIONS) )      ( LEADER-LIST (FOURTH OPTIONS) )      LEADER-LENGTH      ( NEW NIL ))  (SETQ DIMENSIONS (SECOND OPTIONS))  (COND ((NUMBERP LEADER-LIST) (SETQ LEADER-LENGTH LEADER-LIST       LEADER-LIST NIL))((QUOTEP LEADER-LIST) (SETQ LEADER-LIST (LIST 'QUOTE (REVERSE (SECOND LEADER-LIST)))))((NULL LEADER-LIST))(T (SETQ LEADER-LIST `(REVERSE ,LEADER-LIST))))  (UNLESS (NULL (SIXTH OPTIONS))    (SETQ NEW (LIST* :NAMED-STRUCTURE-SYMBOL (SIXTH OPTIONS) NEW)))  (UNLESS (NULL (FIFTH OPTIONS))    (SETQ NEW (LIST* :DISPLACED-INDEX-OFFSET (FIFTH OPTIONS) NEW)))  (UNLESS (NULL (THIRD OPTIONS))    (SETQ NEW (LIST* :DISPLACED-TO (THIRD OPTIONS) NEW)))  (UNLESS (NULL LEADER-LENGTH)    (SETQ NEW (LIST* :LEADER-LENGTH LEADER-LENGTH NEW)))  (UNLESS (NULL LEADER-LIST)    (SETQ NEW (LIST* :LEADER-LIST LEADER-LIST NEW)))  (UNLESS (NULL AREA)    (SETQ NEW (LIST* :AREA AREA NEW)))  (UNLESS (OR (NULL TYPE)      (EQUAL TYPE '(QUOTE ART-Q)))    (SETQ NEW (LIST* :TYPE TYPE NEW)))  (SETQ NEW (LIST* 'MAKE-ARRAY DIMENSIONS NEW))  (LET ((SI:WARNINGS-PRINLENGTH NIL)(SI:WARNINGS-PRINLEVEL 2)(*PRINT-PRETTY* T))    (WARN 'MAKE-ARRAY-STYLE :VERY-OBSOLETE  "Obsolete usage: ~S~%use: ~S instead." FORM NEW) )  )      (LET ( TYPE ELT )(WHEN (AND COMPILING-COMMON-LISP   (SETQ TYPE (GETF OPTIONS ':TYPE))   (QUOTEP TYPE)   #-compiler:debug *WARN-OF-SUPERSEDED-FUNCTIONS-P*   (NOT SI:FILE-IN-COLD-LOAD)   (NEQ *PACKAGE* KERNEL-PACKAGE)   (SETQ TYPE (SECOND TYPE))   (SETQ ELT (RASSOC TYPE '((BIT . ART-1B)   #-explorer  (FIXNUM . ART-32B)   (T . ART-Q)   (STRING-CHAR . ART-STRING)   ((SIGNED-BYTE 16) . ART-HALF-FIX)   ;;#-IEEE-FLOATING-POINT (FLOAT . ART-FLOAT)   (SINGLE-FLOAT . ART-SINGLE-FLOAT)   (SINGLE-FLOAT . ART-FLOAT)   (DOUBLE-FLOAT . ART-DOUBLE-FLOAT)   (FAT-CHAR . ART-FAT-STRING)   ;;#-IEEE-FLOATING-POINT   ;;((COMPLEX FLOAT) . ART-COMPLEX-FLOAT)   ((COMPLEX SINGLE-FLOAT) . ART-COMPLEX-SINGLE-FLOAT)   ((COMPLEX SINGLE-FLOAT) . ART-COMPLEX-FLOAT)   ((COMPLEX DOUBLE-FLOAT) . ART-COMPLEX-DOUBLE-FLOAT)   (COMPLEX . ART-COMPLEX)   #+explorer  (FIXNUM . ART-FIX)   ((UNSIGNED-BYTE 1) . ART-1B)   ((UNSIGNED-BYTE 2) . ART-2B)   ((UNSIGNED-BYTE 4) . ART-4B)   ((UNSIGNED-BYTE 8) . ART-8B)   ((UNSIGNED-BYTE 16) . ART-16B)   #+explorer  ((UNSIGNED-BYTE 32) . ART-32B)   ((SIGNED-BYTE 16) . ART-HALF-FIX))     :TEST #'EQ))  )  (WARN :ELEMENT-TYPE :OBSOLETE"The MAKE-ARRAY option :TYPE '~A has been superseded in Common Lisp by :ELEMENT-TYPE '~A."TYPE (CAR ELT))  )(WHEN (AND (SETQ TYPE (GETF OPTIONS ':ELEMENT-TYPE))   (QUOTEP TYPE)   (SETQ TYPE (SECOND TYPE))   (SETQ ELT (ASSOC TYPE '((FLOAT SINGLE-FLOAT DOUBLE-FLOAT)   ((COMPLEX FLOAT) (COMPLEX SINGLE-FLOAT) (COMPLEX-DOUBLE-FLOAT)))    :TEST #'EQUAL))   (COMPILING-FOR-V2))  (WARN 'ART-FLOAT :IMPLAUSIBLE "MAKE-ARRAY with :ELEMENT-TYPE '~A would be more efficient if specified as '~A or '~A."TYPE (SECOND ELT) (THIRD ELT)) ))))  NIL);;;;    ==================================;;;;       Obsolete variable warnings;;;;    ==================================#+Elroy ; the release 3 reader doesn't use this anymore(MAKE-VARIABLE-OBSOLETE SI:READ-AREA "DEFAULT-CONS-AREA");;;;    ==================================;;;; Style checkers;;;;    ==================================(ADD-STYLE-CHECKER PLUS NEED-TWO-ARGS)(ADD-STYLE-CHECKER TIMES NEED-TWO-ARGS)(ADD-STYLE-CHECKER QUOTIENT NEED-TWO-ARGS)(ADD-STYLE-CHECKER DIFFERENCE NEED-TWO-ARGS)(ADD-STYLE-CHECKER *CATCH NEED-TWO-ARGS) ; added 10/14/86(defun (:property append style-checker) (form)  (need-two-args form)  (when (and (= (length form) 3)     (MEMBER (THIRD FORM) '(NIL (QUOTE NIL)) :TEST #'EQUAL))    (let ((SI:WARNINGS-PRINLENGTH 3) (SI:WARNINGS-PRINLEVEL 2))      (warn 'obsolete ':obsolete "(APPEND ~S NIL) is an obsolete way to copy lists;   use (COPY-LIST ~S) instead." (cadr form) (cadr form)))))(defun (:property subst style-checker) (form)  (when (and (= (length form) 4);don't give too many warnings!     (MEMBER (CADR FORM) '(NIL (QUOTE NIL)) :TEST #'EQUAL)      (MEMBER (CADDR FORM) '(NIL (QUOTE NIL)) :TEST #'EQUAL))    (let ((SI:WARNINGS-PRINLENGTH 3) (SI:WARNINGS-PRINLEVEL 2))      (warn 'obsolete ':obsolete "(SUBST NIL NIL ~S) is an obsolete way to copy trees;   use (COPY-TREE ~S) instead." (cadddr form) (cadddr form)))))(DEFUN (:PROPERTY SI:FSET-CAREFULLY STYLE-CHECKER) ( FORM )  ;; 12/16/85 DNG - Original.  (LET (( SI:WARNINGS-PRINLENGTH 5)( SI:WARNINGS-PRINLEVEL 2))    (WARN 'OBSOLETE ':OBSOLETE "~A is an obsolete function; use ~S"  (FIRST FORM)  `(FDEFINE ,(SECOND FORM) ,(THIRD FORM) T . ,(NTHCDR 3 FORM)) ) ) ) nconc (list* (locf (fsymeval (car elt))) nil nil)) cw-function-environment)))    (setq bindlist (cw-flet-binding-list (cadr exp)))        (setq body (cw-clause (cddr exp)))    (if cw-return-expansion-flag(list* 'labels bindlist body))))#-Elroy ; these are all macros now in release 3(progn;;; Top-level function-defining special forms that look like:;;;     (operation name arglist . body);;; While BREAKOFF should never see these, the user might want to do;;; MACROEXPAND-ALL on one.   For the purposes of the code walker, they;;; can all be treated the same as a NAMED-LAMBDA form.(defprop defun    cw-defun cw-handler)(defprop defsubst cw-defun cw-handler)(defprop defmacro cw-defun c