add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
561
CLTL2/CMLCOMPILE
Normal file
561
CLTL2/CMLCOMPILE
Normal file
@@ -0,0 +1,561 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "18-Oct-93 10:39:21" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;2" 31069
|
||||
|
||||
previous date%: "30-Mar-92 12:16:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;1")
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLCOMPILECOMS)
|
||||
|
||||
(RPAQQ CMLCOMPILECOMS
|
||||
[(COMS (FUNCTIONS LISP:DISASSEMBLE)
|
||||
(FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P
|
||||
COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE
|
||||
COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION
|
||||
COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE)
|
||||
(FNS COMPILE-FILE-SCAN-FIRST)
|
||||
(* ;
|
||||
"This function is support for AR#11185")
|
||||
(VARS ARGTYPE.VARS)
|
||||
(PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT)
|
||||
(FUNCTIONS COMPILE-FILE-DECLARE%:))
|
||||
[COMS (FNS NEWDEFC)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'NEWDEFC 'DEFC]
|
||||
(PROP FILETYPE CMLCOMPILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA FAKE-COMPILE-FILE])
|
||||
|
||||
(LISP:DEFUN LISP:DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8)
|
||||
(OUTPUT *STANDARD-OUTPUT*)
|
||||
FIRST-BYTE MARKED-PC)
|
||||
(PRINTCODE (if (CCODEP NAME-OR-COMPILED-FUNCTION)
|
||||
then NAME-OR-COMPILED-FUNCTION
|
||||
else (LISP:COMPILE NIL (if (LISP:SYMBOLP NAME-OR-COMPILED-FUNCTION)
|
||||
then (LISP:SYMBOL-FUNCTION
|
||||
NAME-OR-COMPILED-FUNCTION)
|
||||
else NAME-OR-COMPILED-FUNCTION)))
|
||||
LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC))
|
||||
(DEFINEQ
|
||||
|
||||
(FAKE-COMPILE-FILE
|
||||
(LISP:LAMBDA
|
||||
(FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
|
||||
(COMPILER-OUTPUT T)
|
||||
(PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 29-Jun-90 19:19 by nm")
|
||||
(LET
|
||||
(COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML)
|
||||
(NLAMA NLAMA)
|
||||
(LAMS LAMS)
|
||||
(LAMA LAMA)
|
||||
(DFNFLG NIL))
|
||||
(DECLARE (LISP:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG))
|
||||
(RESETLST
|
||||
(RESETSAVE NIL (LIST 'RESETUNDO)
|
||||
(RESETUNDO))
|
||||
(RESETSAVE COUTFILE COMPILER-OUTPUT)
|
||||
(RESETSAVE STRF REDEFINE)
|
||||
(RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER))
|
||||
(RESETSAVE LAPFLG LAP)
|
||||
(LET
|
||||
((*PACKAGE* *INTERLISP-PACKAGE*)
|
||||
(*READ-BASE* 10)
|
||||
(LOCALVARS SYSLOCALVARS)
|
||||
(SPECVARS T)
|
||||
STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
|
||||
(DECLARE (LISP:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
|
||||
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
|
||||
(SETQ STREAM (OPENSTREAM FILENAME 'INPUT]
|
||||
(LISP:MULTIPLE-VALUE-SETQ (ENV FORM)
|
||||
(\PARSE-FILE-HEADER STREAM 'RETURN T))
|
||||
(SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
|
||||
(if (NOT PEFP)
|
||||
then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
|
||||
(if LAP
|
||||
then (SETQ LSTFIL COUTFILE))
|
||||
(SETQ FILENAME (FULLNAME STREAM))
|
||||
(RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
|
||||
[SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING
|
||||
'VERSION NIL
|
||||
'EXTENSION COMPILE.EXT
|
||||
'BODY FILENAME))
|
||||
'OUTPUT
|
||||
'NEW
|
||||
'((TYPE BINARY]
|
||||
STREAM
|
||||
(ROOTFILENAME FILENAME)))
|
||||
(if OUTPUT-FILE
|
||||
then (RESETSAVE LCFIL OUTPUT-FILE)
|
||||
(PRINT-COMPILE-HEADER (LIST STREAM)
|
||||
'("COMPILE-FILEd")
|
||||
ENV))
|
||||
(WITH-READER-ENVIRONMENT ENV
|
||||
(PROG ((DEFERRED.EXPRESSIONS NIL)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(FIRSTFORMS NIL)
|
||||
(AFTERS NIL)
|
||||
(SCRATCH.LCOM '{CORE}SCRATCH.LCOM)
|
||||
DUMMYFILE TEMPVAL)
|
||||
(DECLARE (LISP:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL*
|
||||
*PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS))
|
||||
(* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)")
|
||||
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
|
||||
(SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW]
|
||||
LPDUMP
|
||||
[if (EQUAL (CAR FORM)
|
||||
'RPAQQ)
|
||||
then (* ;
|
||||
"This is the support method of %"COMPILERVARS%" (2-July-1990 TT)")
|
||||
(SETQ TEMPVAL (CADDR FORM))
|
||||
(if (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL))
|
||||
then (if (SETQ TEMPVAL (FMEMB 'COMPILERVARS
|
||||
(FMEMB 'DOEVAL@COMPILE TEMPVAL
|
||||
)))
|
||||
then (SETQ DFNFLG T)
|
||||
(if [SETQ TEMPVAL (FMEMB 'ADDVARS
|
||||
(SETQ TEMPVAL
|
||||
(CADR TEMPVAL]
|
||||
then (LISP:DOLIST (ARG (CDR TEMPVAL))
|
||||
(APPLY 'ADDTOVAR ARG))]
|
||||
(COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE)
|
||||
(SKIPSEPRCODES STREAM)
|
||||
(if (EOFP STREAM)
|
||||
then (CLOSEF STREAM)
|
||||
(for FORM in FIRSTFORMS
|
||||
do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL
|
||||
PROCESS-ENTIRE-FILE T))
|
||||
(COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE))
|
||||
(CLOSEF? DUMMYFILE)
|
||||
(DELFILE (FULLNAME DUMMYFILE))
|
||||
(AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE
|
||||
DEFERRED.EXPRESSIONS
|
||||
)
|
||||
do (APPLY* (CAR EXP)
|
||||
(CDR EXP)
|
||||
OUTPUT-FILE)))
|
||||
(for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM
|
||||
OUTPUT-FILE NIL
|
||||
PROCESS-ENTIRE-FILE T))
|
||||
(RETURN))
|
||||
(SETQ FORM (READ STREAM))
|
||||
(GO LPDUMP))
|
||||
(PRINT NIL OUTPUT-FILE))
|
||||
(SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ;
|
||||
"Do these after UNDONLSETQ entered")
|
||||
(MAPC (REVERSE COMPILE.FILE.AFTER)
|
||||
(FUNCTION EVAL))
|
||||
COMPILE.FILE.VALUE)))
|
||||
|
||||
(INTERLISP-FORMAT-P
|
||||
[LAMBDA (STREAM) (* bvm%: " 3-Aug-86 14:01")
|
||||
(SELCHARQ (PEEKCCODE STREAM)
|
||||
(; NIL)
|
||||
((^F "(")
|
||||
T)
|
||||
NIL])
|
||||
|
||||
(INTERLISP-NLAMBDA-FUNCTION-P
|
||||
[LAMBDA (X) (* lmm " 7-May-86 20:12")
|
||||
(AND (LITATOM X)
|
||||
(FMEMB (ARGTYPE X)
|
||||
'(1 3))
|
||||
(NOT (LISP:SPECIAL-FORM-P X])
|
||||
|
||||
(COMPILE-FILE-EXPRESSION
|
||||
[LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
|
||||
(* ; "Edited 30-Jun-90 18:31 by nm")
|
||||
(DECLARE (LISP:SPECIAL COMPILED.FILE))
|
||||
(AND (LISTP FORM)
|
||||
(SELECTQ (CAR FORM)
|
||||
((DECLARE%: FILECREATED)
|
||||
(COMPILE-FILE-SCAN-FIRST FORM COMPILED.FILE NIL T COMPILE.TIME.TOO DEFER
|
||||
FORCE-OUTPUT-P))
|
||||
((DEFMACRO)
|
||||
(LET* ((DEFINITION (REMOVE-COMMENTS FORM))
|
||||
(NAME (XCL::%%DEFINER-NAME 'DEFMACRO DEFINITION))
|
||||
(BODY (XCL::%%EXPAND-DEFINER 'DEFMACRO DEFINITION)))
|
||||
(LISP:EVAL BODY)
|
||||
(COMPILE-FILE-EXPRESSION BODY COMPILED.FILE COMPILE.TIME.TOO DEFER
|
||||
FORCE-OUTPUT-P)))
|
||||
((PROGN)
|
||||
(for X in (CDR FORM) do (COMPILE-FILE-EXPRESSION X COMPILED.FILE
|
||||
COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)))
|
||||
((QUOTE) (* ;
|
||||
" ignore top level quoted expression -i")
|
||||
NIL)
|
||||
((LISP:COMPILER-LET) (* ; " top level compiler-let. bind variables and recursively compile sub-expressions. This is here mainly for b PCL has top level compiler-lets")
|
||||
[LET [(VARS (LISP:MAPCAR #'(LISP:LAMBDA (X)
|
||||
(if (LISP:CONSP X)
|
||||
then (CAR X)
|
||||
else X))
|
||||
(CADR FORM)))
|
||||
(VALS (LISP:MAPCAR #'[LISP:LAMBDA (X)
|
||||
(if (LISP:CONSP X)
|
||||
then (LISP:EVAL (CADR X]
|
||||
(CADR FORM]
|
||||
(LISP:PROGV VARS VALS
|
||||
(LISP:MAPC #'(LISP:LAMBDA (X)
|
||||
(COMPILE-FILE-EXPRESSION X COMPILED.FILE
|
||||
COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
|
||||
(CDDR FORM)))])
|
||||
((LISP:EVAL-WHEN)
|
||||
[LET [[EVAL.SPECIFIED (OR (FMEMB 'EVAL (CADR FORM))
|
||||
(FMEMB 'LISP:EVAL (CADR FORM]
|
||||
[LOAD.SPECIFIED (OR (FMEMB 'LOAD (CADR FORM))
|
||||
(FMEMB 'LISP:LOAD (CADR FORM]
|
||||
(COMPILE.SPECIFIED (OR (FMEMB 'COMPILE (CADR FORM))
|
||||
(FMEMB 'LISP:COMPILE (CADR FORM]
|
||||
(COND
|
||||
[(NOT LOAD.SPECIFIED)
|
||||
(COND
|
||||
((OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED))
|
||||
(for INNER-FORM in (CDDR FORM) do (EVAL INNER-FORM]
|
||||
(T (for INNER-FORM in (CDDR FORM)
|
||||
do (COMPILE-FILE-EXPRESSION INNER-FORM COMPILED.FILE
|
||||
(OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO
|
||||
EVAL.SPECIFIED))
|
||||
DEFER FORCE-OUTPUT-P])
|
||||
((LISP:IN-PACKAGE LISP:IN-PACKAGE) (* ;
|
||||
"These are special because they have to be dumped to the output BEFORE the package changes")
|
||||
(PRINT FORM COMPILED.FILE)
|
||||
(EVAL FORM))
|
||||
((LISP:MAKE-PACKAGE LISP:SHADOW LISP:SHADOWING-IMPORT EXPORT LISP:UNEXPORT
|
||||
LISP:USE-PACKAGE LISP:UNUSE-PACKAGE IMPORT)
|
||||
(* ; "This is Special also, becouse the compiling Environment Must be changed.(see CLtL, 11.7. Package System Functions and Variables) edited by TT(10-April-90)")
|
||||
(PRINT FORM COMPILED.FILE)
|
||||
(EVAL FORM))
|
||||
((LISP:SETQ) (* ;
|
||||
"Gasly kludge because cl:setq needs to run in the init before macroexpansion is enabled")
|
||||
(COMPILE-FILE-EXPRESSION (EXPANDMACRO FORM T)
|
||||
COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
|
||||
(LET [(PROP (OR (GETPROP (CAR FORM)
|
||||
'COMPILE-FILE-EXPRESSION)
|
||||
(GETPROP (CAR FORM)
|
||||
'COMPILE.FILE.EXPRESSION]
|
||||
(if [AND (NOT PROP)
|
||||
(NOT (LISP:SPECIAL-FORM-P (CAR FORM)))
|
||||
(NOT (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM)))
|
||||
(NEQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM]
|
||||
then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER
|
||||
FORCE-OUTPUT-P)
|
||||
else (if COMPILE.TIME.TOO
|
||||
then (EVAL FORM))
|
||||
(if PROP
|
||||
then (COMPILE.FILE.APPLY PROP FORM DEFER FORCE-OUTPUT-P)
|
||||
elseif [NOT (EQUAL FORM (SETQ FORM (WALK-FORM FORM :WALK-FUNCTION
|
||||
(FUNCTION
|
||||
COMPILE-FILE-WALK-FUNCTION
|
||||
]
|
||||
then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE
|
||||
COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
|
||||
else (COMPILE.FILE.APPLY (FUNCTION PRINT)
|
||||
FORM DEFER FORCE-OUTPUT-P])
|
||||
|
||||
(COMPILE-FILE-WALK-FUNCTION
|
||||
[LAMBDA (FORM) (* lmm "26-Jun-86 17:25")
|
||||
(if (NLISTP FORM)
|
||||
then FORM
|
||||
else (LISP:VALUES FORM (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM])
|
||||
|
||||
(ARGTYPE.STATE
|
||||
[LAMBDA NIL
|
||||
(for X in ARGTYPE.VARS do (PRINTOUT T X %, (EVAL (CADR X))
|
||||
T])
|
||||
|
||||
(COMPILE.CHECK.ARGTYPE
|
||||
[LAMBDA (X AT) (* lmm "15-Jun-85 16:58")
|
||||
(if (NEQ AT (LET (BLKFLG)
|
||||
(COMP.ARGTYPE X)))
|
||||
then (* ;
|
||||
"Incorrectly on one of the defining lists")
|
||||
(for ATYPEPAIR in ARGTYPE.VARS
|
||||
do (LET [(VAL (FMEMB X (EVALV (CADR ATYPEPAIR]
|
||||
(if (EQ AT (CAR ATYPEPAIR))
|
||||
then (if VAL
|
||||
then (PRINTOUT COUTFILE "Compiler confused: " X " on "
|
||||
(CADR ATYPEPAIR)
|
||||
" but compiler doesn't think its a "
|
||||
(CADDR ATYPEPAIR)))
|
||||
[/SETTOPVAL (CADR ATYPEPAIR)
|
||||
(CONS X (PROGN (GETTOPVAL (CADR ATYPEPAIR]
|
||||
else (if VAL
|
||||
then (PRINTOUT COUTFILE "Warning: compiler thought " X " "
|
||||
(LIST 'a (OR (CADDR (ASSOC AT ARGTYPE.VARS))
|
||||
"LAMBDA spread")
|
||||
'function)
|
||||
" was a "
|
||||
(CADDR ATYPEPAIR)
|
||||
" because it was incorrectly on "
|
||||
(CADR ATYPEPAIR)
|
||||
T)
|
||||
(/SETTOPVAL (CADR ATYPEPAIR)
|
||||
(REMOVE X (PROGN (GETTOPVAL (CADR ATYPEPAIR])
|
||||
|
||||
(COMPILE.FILE.DEFINEQ
|
||||
[LAMBDA (FORM LCFIL) (* bvm%: "18-Sep-86 14:35")
|
||||
(for DEF in (CDR FORM) unless (FMEMB (CAR DEF)
|
||||
DONTCOMPILEFNS)
|
||||
do (COMPILE.CHECK.ARGTYPE (CAR DEF)
|
||||
(ARGTYPE (CADR DEF)))
|
||||
(BYTECOMPILE2 (CAR DEF)
|
||||
(COMPILE1A (CAR DEF)
|
||||
(CADR DEF)
|
||||
NIL])
|
||||
|
||||
(COMPILE-FILE-SETF-SYMBOL-FUNCTION
|
||||
[LAMBDA (FORM LCFIL) (* bvm%: " 8-Sep-86 16:55")
|
||||
(if [AND (FMEMB (CAR (LISTP (LISP:THIRD FORM)))
|
||||
'(FUNCTION LISP:FUNCTION))
|
||||
(EQ (CAR (LISTP (LISP:SECOND FORM)))
|
||||
'QUOTE)
|
||||
(LISP:CONSP (LISP:SECOND (LISP:THIRD FORM]
|
||||
then (BYTECOMPILE2 (CADR (LISP:SECOND FORM))
|
||||
(CADR (LISP:THIRD FORM)))
|
||||
else (PRINT (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION))
|
||||
LCFIL])
|
||||
|
||||
(COMPILE-FILE-EX/IMPORT
|
||||
[LAMBDA (FORM LCFIL RDTBL) (* bvm%: " 3-Aug-86 15:05")
|
||||
|
||||
(* * "EXPORT, IMPORT, SHADOW, USE-PACKAGE are all implicitly EVAL@COMPILE, since they have to affect the package being used to read what follows")
|
||||
|
||||
(PRINT FORM LCFIL RDTBL)
|
||||
(EVAL FORM])
|
||||
|
||||
(COMPILE.FILE.APPLY
|
||||
[LAMBDA (PROP FORM DEFER FORCE-OUTPUT-P) (* ; "Edited 29-Jun-90 19:21 by nm")
|
||||
(if FORCE-OUTPUT-P
|
||||
then (PRINT FORM COMPILED.FILE)
|
||||
else (if DEFER
|
||||
then (push DEFERRED.EXPRESSIONS (CONS PROP FORM))
|
||||
else (APPLY* PROP FORM COMPILED.FILE])
|
||||
|
||||
(COMPILE.FILE.RESET
|
||||
[LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME) (* bvm%: " 9-Sep-86 15:16")
|
||||
(* Cleans up after brecompile and
|
||||
bcompl have finished operating,)
|
||||
(if (AND COMPILED.FILE (OPENP COMPILED.FILE))
|
||||
then (CLOSE-AND-MAYBE-DELETE COMPILED.FILE))
|
||||
(if SOURCEFILE
|
||||
then (CLOSEF? SOURCEFILE))
|
||||
(if (NULL RESETSTATE)
|
||||
then (* Finished successfully.)
|
||||
(/SETATOMVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
|
||||
(* Removes FILES from
|
||||
NOTCOMPILEDFILES.)])
|
||||
|
||||
(COMPILE-IN-CORE
|
||||
[LAMBDA (fn-name fn-expr fn-type NOSAVE)
|
||||
(DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD))
|
||||
(* lmm " 2-Jun-86 22:04")
|
||||
|
||||
(* in-core compiling for functions and forms, without the interview.
|
||||
if X is a list, we assume that we are being called merely to display the lap
|
||||
and machine code. the form is compiled as the definition of FOO but the
|
||||
compiled :CODE is thrown away. -
|
||||
if X is a litatom, then saving, redefining, and printing is controlled by the
|
||||
flags.)
|
||||
|
||||
(LET ((NOREDEFINE NIL)
|
||||
(PRINTLAP NIL)
|
||||
(DONT-TRANSFER-PUTD T))
|
||||
(RESETVARS [(NLAMA NLAMA)
|
||||
(NLAML NLAML)
|
||||
(LAMS LAMS)
|
||||
(LAMA LAMA)
|
||||
(NOFIXFNSLST NOFIXFNSLST)
|
||||
(NOFIXVARSLST NOFIXVARSLST)
|
||||
(COUTFILE (COND
|
||||
((AND (BOUNDP 'NULLFILE)
|
||||
(STREAMP NULLFILE)
|
||||
(OPENP NULLFILE))
|
||||
NULLFILE)
|
||||
(T (SETQ NULLFILE (OPENFILE '{NULL} 'OUTPUT]
|
||||
(RETURN (RESETLST (* RESETLST to provide reset context
|
||||
for macros under COMPILE1 as
|
||||
generated e.g. by DECL.)
|
||||
[PROG ((LCFIL)
|
||||
[LAPFLG (AND PRINTLAP (COND
|
||||
(BYTECOMPFLG T)
|
||||
(T 2]
|
||||
(STRF (NOT NOREDEFINE))
|
||||
(SVFLG (if (EQ fn-type 'SELECTOR)
|
||||
then 'SELECTOR
|
||||
else (NOT NOSAVE)))
|
||||
(LSTFIL T)
|
||||
(SPECVARS SYSSPECVARS)
|
||||
(LOCALVARS T))
|
||||
(RETURN (PROGN (SETQ fn-expr (COMPILE1A fn-name fn-expr T))
|
||||
(PROG ((FREEVARS FREEVARS))
|
||||
(RETURN (BYTECOMPILE2 fn-name fn-expr])])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(COMPILE-FILE-SCAN-FIRST
|
||||
[LAMBDA (FORM COMPILED.FILE FIRSTFLG DOCOPY EVAL@COMPILE DEFER FORCE-OUTPUT-P)
|
||||
(* ; "Edited 30-Jun-90 18:32 by nm")
|
||||
(* ; "Edited 26-Apr-90 by tt")
|
||||
(* ;
|
||||
"This is enhancement for Fake Compiler's interpretation of file package coms")
|
||||
(PROG ((DFNFLG DFNFLG)
|
||||
(FIRST FIRSTFLG)
|
||||
(DOCOPY DOCOPY)
|
||||
(EVAL@COMPILE EVAL@COMPILE)
|
||||
NOTFIRST)
|
||||
(if (LISTP FORM)
|
||||
then
|
||||
(SELECTQ (CAR FORM)
|
||||
((DECLARE%:)
|
||||
(LISP:DO ((TAIL (CDR FORM)
|
||||
(CDR TAIL)))
|
||||
((LISP:ENDP TAIL))
|
||||
[if (LISP:SYMBOLP (CAR TAIL))
|
||||
then (CASE (CAR TAIL)
|
||||
((DOCOPY COPY) (SETQ DOCOPY T))
|
||||
((DONTCOPY) (SETQ DOCOPY NIL))
|
||||
((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL
|
||||
(CDR TAIL])
|
||||
((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
|
||||
((EVAL@LOADWHEN) (LISP:POP TAIL))
|
||||
((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
|
||||
((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
|
||||
((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE
|
||||
(EVAL (CAR (SETQ TAIL (CDR TAIL])
|
||||
((FIRST)
|
||||
(SETQ FIRST T)
|
||||
(SETQ NOTFIRST NIL))
|
||||
(* ; "for First")
|
||||
((NOTFIRST)
|
||||
(SETQ NOTFIRST T)
|
||||
(SETQ FIRST NIL))
|
||||
(* ; "for Not First")
|
||||
((COMPILERVARS) (SETQ DFNFLG T))
|
||||
(* ; "for Compilervars")
|
||||
(LISP:OTHERWISE (LISP:FORMAT COUTFILE
|
||||
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
|
||||
(CAR TAIL))))
|
||||
else (COND
|
||||
((EQ 'DECLARE%: (CAR (CAR TAIL)))
|
||||
(COMPILE-FILE-SCAN-FIRST (CAR TAIL)
|
||||
COMPILED.FILE FIRST DOCOPY EVAL@COMPILE DEFER))
|
||||
(T (LISP:WHEN EVAL@COMPILE
|
||||
(EVAL (CAR TAIL)))
|
||||
(LISP:WHEN DOCOPY
|
||||
(LISP:IF FIRST
|
||||
(SETQ FIRSTFORMS (NCONC1 FIRSTFORMS (CAR TAIL)))
|
||||
(LISP:IF NOTFIRST
|
||||
(SETQ AFTERS (NCONC1 AFTERS (CAR TAIL)))
|
||||
(COMPILE-FILE-EXPRESSION (CAR TAIL)
|
||||
COMPILED.FILE EVAL@COMPILE DEFER
|
||||
FORCE-OUTPUT-P))))]))
|
||||
((FILECREATED)
|
||||
(if FORCE-OUTPUT-P
|
||||
then (PRINT FORM COMPILED.FILE)
|
||||
else (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS FORM))))
|
||||
NIL])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "This function is support for AR#11185")
|
||||
|
||||
|
||||
(RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread")
|
||||
(2 LAMA "LAMBDA nospread")
|
||||
(0 LAMS "LAMBDA spread")
|
||||
(3 NLAMA "NLAMBDA no-spread")))
|
||||
|
||||
(PUTPROPS DEFINEQ COMPILE-FILE-EXPRESSION COMPILE.FILE.DEFINEQ)
|
||||
|
||||
(PUTPROPS * COMPILE-FILE-EXPRESSION NILL)
|
||||
|
||||
(PUTPROPS SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION)
|
||||
|
||||
(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL)
|
||||
|
||||
(LISP:DEFUN COMPILE-FILE-DECLARE%: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)
|
||||
(LISP:DO ((TAIL (CDR FORM)
|
||||
(CDR TAIL)))
|
||||
((LISP:ENDP TAIL))
|
||||
(LISP:IF (LISP:SYMBOLP (CAR TAIL))
|
||||
(CASE (CAR TAIL)
|
||||
((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
|
||||
((EVAL@LOADWHEN) (LISP:POP TAIL))
|
||||
((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
|
||||
((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
|
||||
((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL])
|
||||
((COPY DOCOPY) (SETQ DOCOPY T))
|
||||
((DONTCOPY) (SETQ DOCOPY NIL))
|
||||
((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL])
|
||||
((FIRST) )
|
||||
((NOTFIRST COMPILERVARS) )
|
||||
(LISP:OTHERWISE (LISP:FORMAT COUTFILE
|
||||
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
|
||||
(CAR TAIL))))
|
||||
[COND
|
||||
((EQ 'DECLARE%: (CAR (CAR TAIL)))
|
||||
(COMPILE-FILE-DECLARE%: (CAR TAIL)
|
||||
COMPILED.FILE EVAL@COMPILE DOCOPY DEFER))
|
||||
(T (LISP:WHEN EVAL@COMPILE
|
||||
(EVAL (CAR TAIL)))
|
||||
(LISP:WHEN DOCOPY
|
||||
(COMPILE-FILE-EXPRESSION (CAR TAIL)
|
||||
COMPILED.FILE EVAL@COMPILE DEFER))])))
|
||||
(DEFINEQ
|
||||
|
||||
(NEWDEFC
|
||||
[LAMBDA (NM DF) (* bvm%: "30-Sep-86 23:12")
|
||||
[COND
|
||||
((EQ SVFLG 'DEFER)
|
||||
(push COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC)
|
||||
(KWOTE NM)
|
||||
(KWOTE DF)
|
||||
T)))
|
||||
((OR (NULL DFNFLG)
|
||||
(EQ DFNFLG T))
|
||||
[COND
|
||||
((GETD NM)
|
||||
(VIRGINFN NM T)
|
||||
(COND
|
||||
((NULL DFNFLG)
|
||||
(LISP:FORMAT *ERROR-OUTPUT* "~&(~S redefined)~%%" NM)
|
||||
(SAVEDEF NM]
|
||||
(/PUTD NM DF T))
|
||||
(T
|
||||
(* ;; "Save on CODE prop. Be nice and change it from archaic CCODEP object to modern compiled code object.")
|
||||
|
||||
(/PUTPROP NM 'CODE (if (ARRAYP DF)
|
||||
then (create COMPILED-CLOSURE
|
||||
FNHEADER _ (fetch (ARRAYP BASE) of DF))
|
||||
else DF]
|
||||
DF])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(MOVD 'NEWDEFC 'DEFC)
|
||||
)
|
||||
|
||||
(PUTPROPS CMLCOMPILE FILETYPE LISP:COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA FAKE-COMPILE-FILE)
|
||||
)
|
||||
(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2394 23384 (FAKE-COMPILE-FILE 2404 . 8967) (INTERLISP-FORMAT-P 8969 . 9191) (
|
||||
INTERLISP-NLAMBDA-FUNCTION-P 9193 . 9429) (COMPILE-FILE-EXPRESSION 9431 . 15709) (
|
||||
COMPILE-FILE-WALK-FUNCTION 15711 . 15960) (ARGTYPE.STATE 15962 . 16124) (COMPILE.CHECK.ARGTYPE 16126
|
||||
. 18118) (COMPILE.FILE.DEFINEQ 18120 . 18615) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18617 . 19227) (
|
||||
COMPILE-FILE-EX/IMPORT 19229 . 19557) (COMPILE.FILE.APPLY 19559 . 19921) (COMPILE.FILE.RESET 19923 .
|
||||
20784) (COMPILE-IN-CORE 20786 . 23382)) (23385 27623 (COMPILE-FILE-SCAN-FIRST 23395 . 27621)) (29617
|
||||
30683 (NEWDEFC 29627 . 30681)))))
|
||||
STOP
|
||||
Reference in New Issue
Block a user