From c13cfaca17913baf572bc793ef9428bddebc2708 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Sun, 5 Aug 2018 15:48:06 -0700 Subject: [PATCH] Updated transs (macsyma source) to be based on latest version from MC backup tapes (90) but with fixes so that it actually works. Previously translate_file failed with version 90. Resolves #1152. --- build/lisp.tcl | 1 + src/transl/transs.91 | 529 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 530 insertions(+) create mode 100644 src/transl/transs.91 diff --git a/build/lisp.tcl b/build/lisp.tcl index 146edefe..271c81d5 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -557,6 +557,7 @@ respond "(C3)" "quit();" respond "*" "macsym\013" respond "(C1)" "compile_lisp_file(translate_file(\"share\\;eigen >\")\[2\]);" respond "Type ALL;" "all;" +respond "Type ALL;" "all;" respond "(C2)" "quit();" ### build share;array fasl and ellen; check fasl for macsyma diff --git a/src/transl/transs.91 b/src/transl/transs.91 new file mode 100644 index 00000000..8bb0c142 --- /dev/null +++ b/src/transl/transs.91 @@ -0,0 +1,529 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module transs) + +(TRANSL-MODULE TRANSS) + + +(DEFMVAR *TRANSL-FILE-DEBUG* NIL + "set this to T if you don't want to have the temporary files + used automaticaly deleted in case of errors.") + +;;; User-hacking code, file-io, translator toplevel. +;;; There are various macros to cons-up filename TEMPLATES +;;; which to mergef into. The filenames are should be the only +;;; system dependant part of the code, although certain behavior +;;; of RENAMEF/MERGEF/DELETEF is assumed. + +(defmvar $TR_OUTPUT_FILE_DEFAULT '$TRLISP + "This is the second file name to be used for translated lisp + output.") + +(DEFMVAR $TR_FILE_TTY_MESSAGESP NIL + "It TRUE messages about translation of the file are sent + to the TTY also.") + +(DEFMVAR $TR_WINDY T + "Generate /"helpfull/" comments and programming hints.") + +(DEFTRVAR *TRANSLATION-MSGS-FILES* NIL + "Where the warning and other comments goes.") + +(DEFTRVAR $TR_VERSION (GET 'TRANSL-AUTOLOAD 'VERSION)) + +(DEFMVAR TRANSL-FILE NIL "output stream of $COMPFILE and $TRANSLATE_FILE") + +(DEFMVAR $COMPGRIND NIL "If TRUE lisp output will be pretty-printed.") + +(DEFMVAR $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED nil + "This is set by TRANSLATE_FILE for use by user macros + which want to know the name of the source file.") + +(DEFMVAR $TR_STATE_VARS + '((MLIST) $TRANSCOMPILE $TR_SEMICOMPILE + $TR_WARN_UNDECLARED + $TR_WARN_MEVAL + $TR_WARN_FEXPR + $TR_WARN_MODE + $TR_WARN_UNDEFINED_VARIABLE + $TR_FUNCTION_CALL_DEFAULT + $TR_ARRAY_AS_REF + $TR_NUMER + $DEFINE_VARIABLE)) + +(defmacro compfile-outputname-temp () + #-(or Multics Lispm) ''|_CMF_ OUTPUT| + #+Multics ''(* _cmf_ output) + #+LispM '`,(fs:parse-pathname "_cmf_")) + +(defmacro compfile-outputname () + #-(or Multics Lispm)'`((DSK ,(STATUS UDIR)) + ,(STATUS USERID) + ,(stripdollar $TR_OUTPUT_FILE_DEFAULT)) + #+Multics '`(,(status udir) ,(stripdollar $tr_output_file_default)) + #+LispM '`,(fs:parse-pathname (stripdollar $tr_output_file_default))) + +(defmacro trlisp-inputname-d1 () + ;; so hacks on DEFAULTF will not stray the target. + #-(or Multics Lispm) '`((dsk ,(status udir)) * >) + #+Multics '`(,(status udir) * *) + #+LispM '`,(fs:parse-pathname "")) + +(defmacro trlisp-outputname-d1 () + #-(or Multics Lispm) '`((* *) * ,(stripdollar $TR_OUTPUT_FILE_DEFAULT)) + #+Multics '`(* * ,(stripdollar $tr_output_file_default)) + #+LispM '`,(fs:parse-pathname (stripdollar $tr_output_file_default))) + +(defmacro trlisp-outputname () + #-(or Multics Lispm) ''|* TRLISP| + #+Multics ''(* * lisp) + #+LispM '`,(send (fs:parse-pathname "") ':new-canonical-type ':lisp)) + +(defmacro trlisp-outputname-temp () + #-(or Multics Lispm) ''|* _TRLI_| + #+Multics ''(* * _trli_) + #+LispM '`,(fs:parse-pathname "_trli_")) + +(defmacro trtags-outputname () + #-(or Multics Lispm) ''|* TAGS| + #+Multics ''(* * tags) + #+LispM '`,(fs:parse-pathname "tags")) + +(defmacro trtags-outputname-temp () + #-(or Multics Lispm) ''|* _TAGS_| + #+Multics ''(* * _tags_) + #+LispM '`,(fs:parse-pathname "_tags_")) + + +(defmacro trcomments-outputname () + #-(or Multics Lispm) ''|* UNLISP| + #+Multics ''(* * unlisp) + #+LispM '`,(fs:parse-pathname "unlisp")) + +(defmacro trcomments-outputname-temp () + #-(or Multics Lispm) ''|* _UNLI_| + #+Multics ''(* * _unli_) + #+LispM '`,(fs:parse-pathname "_unli_")) + +(DEFTRVAR DECLARES NIL) + +(DEFMSPEC $COMPFILE (FORMS) (setq forms (cdr forms)) + (bind-transl-state + (SETQ $TRANSCOMPILE T + *IN-COMPFILE* T) + (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS)) + ($FILENAME_MERGE (POP FORMS))) + (T ""))) + (t-error nil) + (*TRANSLATION-MSGS-FILES* NIL)) + (SETQ OUT-FILE-NAME + (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME))) + (UNWIND-PROTECT + (PROGN + (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP) + OUT-FILE-NAME))) + + (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS)) + (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS))))) + (DO ((L FORMS (CDR L)) + (DECLARES NIL NIL) + (TR-ABORT NIL NIL) + (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL) + (T-ITEM)) + ((NULL L)) + (SETQ ITEM (CAR L)) + (COND ((NOT (ATOM ITEM)) + (PRINT* (DCONVX (TRANSLATE ITEM)))) + (T + (SETQ T-ITEM + (COMPILE-FUNCTION + (SETQ ITEM ($VERBIFY ITEM)))) + (COND (TR-ABORT + (SETQ T-ERROR + (PRINT-ABORT-MSG ITEM + 'COMPFILE))) + (T + (COND ($COMPGRIND + (MFORMAT TRANSL-FILE + "~2%;; Function ~:@M~%" ITEM))) + (PRINT* T-ITEM)))))) + (RENAME-TF OUT-FILE-NAME NIL) + (TO-MACSYMA-NAMESTRING OUT-FILE-NAME)) + ;; unwind-protected + (IF TRANSL-FILE (CLOSE TRANSL-FILE)) + (IF T-ERROR (DELETEF TRANSL-FILE)))))) + + +(DEFUN COMPILE-FUNCTION (F) + (MFORMAT *TRANSLATION-MSGS-FILES* + "~%Translating ~:@M" F) + (LET ((FUN (TR-MFUN F))) + (COND (TR-ABORT NIL) + (T FUN)))) + +(DEFVAR TR-DEFAULTF NIL + "A default only for the case of NO arguments to $TRANSLATE_FILE") + +;;; Temporary hack during debugging of this code. +#+LispM +(progn 'compile +(defmacro mergef (x y) `(fs:merge-pathnames ,x ,y)) +(defmacro truename (x) `(let ((name (send ,x ':truename))) + (if name name ,x))) +) + +(DEFMFUN $TRANSLATE_FILE (&OPTIONAL (INPUT-FILE-NAME NIL I-P) + (OUTPUT-FILE-NAME NIL O-P)) + (OR I-P TR-DEFAULTF + (MERROR "Arguments are input file and optional output file~ + ~%which defaults to second name LISP, msgs are put~ + ~%in file with second file name UNLISP")) + (COND (I-P + (SETQ INPUT-FILE-NAME (MERGEF ($FILENAME_MERGE INPUT-FILE-NAME) + (trlisp-inputname-d1))) + (SETQ TR-DEFAULTF INPUT-FILE-NAME)) + (T + (SETQ TR-DEFAULTF INPUT-FILE-NAME))) + (SETQ OUTPUT-FILE-NAME + (IF O-P + (MERGEF ($FILENAME_MERGE OUTPUT-FILE-NAME) INPUT-FILE-NAME) + (MERGEF (TRLISP-OUTPUTNAME-D1) INPUT-FILE-NAME))) + (TRANSLATE-FILE INPUT-FILE-NAME + OUTPUT-FILE-NAME + $TR_FILE_TTY_MESSAGESP)) + + +(DEFMVAR $TR_GEN_TAGS NIL + "If TRUE, TRANSLATE_FILE generates a TAGS file for + use by the text editor") + +(DEFVAR TRF-START-HOOK NIL) + +#-LispM +(DEFUN DELETE-OLD-AND-OPEN (X) + (IF (LET ((F (PROBEF X))) + (AND F (NOT (MEMQ (CADDR (NAMELIST #-Franz F #+Franz X)) '(< >))))) + (DELETEF X)) + (OPEN-OUT-DSK X)) + +#+LispM +(DEFUN DELETE-OLD-AND-OPEN (X) + (LET* ((F (PROBEF X)) + (VER (IF F (SEND F ':VERSION)))) + (if (OR (NUMBERP VER) + (EQ VER ':UNSPECIFIC)) + (DELETEF X))) + (OPEN-OUT-DSK X)) + +(DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME TTYMSGSP) + (BIND-TRANSL-STATE + (SETQ *IN-TRANSLATE-FILE* T) + (LET ((IN-FILE) + (*TRANSLATION-MSGS-FILES*) + (DSK-MSGS-FILE) + (TAGS-OUTPUT-STREAM) + (TAGS-OUTPUT-STREAM-STATE) + (WINP NIL) + (TYO (IF (BOUNDP 'TYO) TYO T)) + (TRUE-IN-FILE-NAME)) + (UNWIND-PROTECT + (PROGN + (SETQ IN-FILE (OPEN-in-dsk IN-FILE-NAME) + TRUE-IN-FILE-NAME (TO-MACSYMA-NAMESTRING (TRUENAME IN-FILE)) + $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED TRUE-IN-FILE-NAME + TRANSL-FILE (DELETE-OLD-AND-OPEN + (MAKE-TRANSL-FILE-TEMP-NAME OUT-FILE-NAME)) + DSK-MSGS-FILE (DELETE-OLD-AND-OPEN + (MAKE-MSGS-FILE-TEMP-NAME OUT-FILE-NAME)) + *TRANSLATION-MSGS-FILES* (LIST DSK-MSGS-FILE)) + (IF $TR_GEN_TAGS + (SETQ TAGS-OUTPUT-STREAM + (OPEN-out-dsk (MERGEF (trtags-outputname-temp) + IN-FILE-NAME)))) + (IF TTYMSGSP + (SETQ *TRANSLATION-MSGS-FILES* + (CONS TYO *TRANSLATION-MSGS-FILES*))) + (PROGN (CLOSE IN-FILE) + ;; IN-FILE stream of no use with old-io BATCH1. + (SETQ IN-FILE NIL)) + (MFORMAT DSK-MSGS-FILE "~%This is the UNLISP file for ~A.~%" + TRUE-IN-FILE-NAME) + (MFORMAT TERMINAL-IO "~%Translation begun on ~A.~%" + TRUE-IN-FILE-NAME) + (IF TRF-START-HOOK (FUNCALL TRF-START-HOOK TRUE-IN-FILE-NAME)) + (IF TAGS-OUTPUT-STREAM (TAGS-START//END IN-FILE-NAME)) + #-MAXII(CALL-BATCH1 TRUE-IN-FILE-NAME (NOT *TRANSL-FILE-DEBUG*)) + #+MAXII(READ-AND-TRANSLATE TRUE-IN-FILE-NAME (NOT *TRANSL-FILE-DEBUG*)) + ;; BATCH1 calls TRANSLATE-MACEXPR on each expression read. + (MFORMAT DSK-MSGS-FILE + "~%//* Variable settings were *//~%~%") + (DO ((L (CDR $TR_STATE_VARS) (CDR L))) + ((NULL L)) + (MFORMAT-OPEN DSK-MSGS-FILE + "~:M:~:M;~%" + (CAR L) (SYMEVAL (CAR L)))) + (RENAME-TF OUT-FILE-NAME TRUE-IN-FILE-NAME) + (WHEN TAGS-OUTPUT-STREAM + (TAGS-START//END) + ;;(CLOSE TAGS-OUTPUT-STREAM) + (RENAMEF TAGS-OUTPUT-STREAM (trtags-outputname))) + ;;(CLOSE DSK-MSGS-FILE) + ;; The CLOSE before RENAMEF clobbers the old temp file. + ;; nope. you get a FILE-ALREADY-EXISTS error. darn. + (let ((TR-COMMENT-FILE-NAME (MAKE-MSGS-FILE-NAME OUT-FILE-NAME))) + (if (probef tr-comment-file-name) + (deletef tr-comment-file-name)) + #+LispM + (close dsk-msgs-file) + (RENAMEF DSK-MSGS-FILE tr-comment-file-name) + (SETQ WINP T) + `((MLIST) ,(TO-MACSYMA-NAMESTRING TRUE-IN-FILE-NAME) + ,(TO-MACSYMA-NAMESTRING OUT-FILE-NAME) + ,(TO-MACSYMA-NAMESTRING (TRUENAME DSK-MSGS-FILE)) + ,@(IF TAGS-OUTPUT-STREAM + (LIST (TO-MACSYMA-NAMESTRING + (TRUENAME TAGS-OUTPUT-STREAM))) + NIL)))) + ;; Unwind protected. + (IF DSK-MSGS-FILE (CLOSE DSK-MSGS-FILE)) + (IF TRANSL-FILE (CLOSE TRANSL-FILE)) + (IF TAGS-OUTPUT-STREAM (CLOSE TAGS-OUTPUT-STREAM)) + (WHEN (AND (NOT WINP) (NOT *TRANSL-FILE-DEBUG*)) + (IF TAGS-OUTPUT-STREAM (DELETEF TAGS-OUTPUT-STREAM)) + (IF TRANSL-FILE (DELETEF TRANSL-FILE))))))) + +#-LispM +(defun make-transl-file-temp-name (out-file-name) + (MERGEF (trlisp-outputname-temp) out-file-name)) + +#+LispM +(defun make-transl-file-temp-name (out-file-name) + (send (fs:parse-pathname out-file-name) ':new-raw-name (send (trlisp-outputname-temp) + ':raw-name))) + +#-LispM +(defun make-msgs-file-name (out-file-name) + (mergef (trcomments-outputname) out-file-name)) + + +#+LispM +(defun make-msgs-file-name (out-file-name) + (send (fs:parse-pathname out-file-name) ':new-raw-name (send (trcomments-outputname) + ':raw-name))) + +#-LispM +(defun make-msgs-file-temp-name (out-file-name) + (MERGEF (trcomments-outputname-temp) out-file-name)) + +#+LispM +(defun make-msgs-file-temp-name (out-file-name) + (send (fs:parse-pathname out-file-name) ':new-raw-name (send (trcomments-outputname-temp) + ':raw-name))) + + +#+LispM +(DEFUN READ-AND-TRANSLATE (FILENAME SILENT-P) + (LET ((EOF (LIST NIL)) + (NAME ($FILENAME_MERGE FILENAME)) + (*MREAD-PROMPT* "(Translating) ")) + (TRUEFNAME NAME) + (IF $LOADPRINT (MTELL "~%Translating the file ~M~%" NAME)) + (WITH-OPEN-FILE (STREAM NAME '(:IN :ASCII)) + (DO ((FORM NIL (MREAD STREAM EOF))) + ((EQ FORM EOF) + (IF $LOADPRINT (MTELL "Translation done.~%")) + '$DONE) + (TRANSLATE-MACEXPR-ACTUAL (CADDR FORM) 0.))))) + +;; Should be rewritten to use streams. Barf -- perhaps SPRINTER doesn't take +;; a stream argument? Yes Carl SPRINTER is old i/o, but KMP is writing +;; a new one for NIL. -GJC + +(DEFUN PRINT* (P) + (LET ((^W T) + (OUTFILES (LIST TRANSL-FILE)) + (^R T) + (*NOPOINT NIL) + ($LOADPRINT NIL)) ;;; lusing old I/O !!!!! + (SUB-PRINT* P))) + +;;; i might as well be real pretty and flatten out PROGN's. + +(DEFUN SUB-PRINT* (P &AUX (FLAG NIL)) + (COND ((ATOM P)) + ((AND (EQ (CAR P) 'PROGN) (CDR P) (EQUAL (CADR P) ''COMPILE)) + (MAPC #'SUB-PRINT* (CDDR P))) + (T + (SETQ FLAG (AND $TR_SEMICOMPILE + (NOT (MEMQ (CAR P) '(EVAL-WHEN INCLUDEF))))) + (WHEN FLAG (PRINC* '|(PROGN|) (TERPRI*)) + (COND ($COMPGRIND + (SPRIN1 P)) + (T + (PRIN1 P TRANSL-FILE))) + (WHEN FLAG (PRINC* '|)|)) + (TERPRI TRANSL-FILE)))) + +(DEFUN PRINC* (FORM) (PRINC FORM TRANSL-FILE)) + +(DEFUN NPRINC* (&REST FORM) + (MAPC #'(LAMBDA (X) (PRINC X TRANSL-FILE)) FORM)) + +(DEFUN TERPRI* () (TERPRI TRANSL-FILE)) + +(DEFUN PRINT-MODULE (M) + (NPRINC* " " M " version " (GET M 'VERSION))) + +(DEFUN NEW-COMMENT-LINE () + (TERPRI*) + (PRINC* ";;;")) + +(defun print-TRANSL-MODULEs () + (NEW-COMMENT-LINE) + (PRINT-MODULE 'TRANSL-AUTOLOAD) + (DO ((J 0 (1+ J)) + (S (DELETE 'TRANSL-AUTOLOAD (APPEND TRANSL-MODULES NIL)) + (CDR S))) + ((NULL S)) + (IF (= 0 (\ J 3)) (NEW-COMMENT-LINE)) + (PRINT-MODULE (CAR S)))) + + +#-LispM +(defmacro name-for-printing (file) + `',file) + +#+LispM +(defmacro name-for-printing (file) + `(send ,file ':string-for-printing)) + + +(DEFUN PRINT-TRANSL-HEADER (SOURCE) + (MFORMAT TRANSL-FILE + ";;; -*- Mode: Lisp; Package: Macsyma -*-~%") + (IF SOURCE + (MFORMAT TRANSL-FILE ";;; Translated code for ~A" (name-for-printing SOURCE)) + (MFORMAT TRANSL-FILE + ";;; Translated MACSYMA functions generated by COMPFILE.")) + (MFORMAT TRANSL-FILE + "~%;;; Written on ~:M, from MACSYMA ~A~ + ~%;;; Translated for ~A~%" + ($TIMEDATE) $VERSION (sys-user-id)) + (print-TRANSL-MODULEs) + (MFORMAT TRANSL-FILE + ;; The INCLUDEF must be in lower case for transportation + ;; of translated code to Multics. + "~%~ + ~%(includef (cond ((status feature ITS) '|DSK:LIBMAX;TPRELU >|)~ + ~% ((status feature Multics) '|translate|)~ + ~% ((status feature Unix) '|libmax//tprelu.l|)~ + ~% (t (error '|Unknown system, see GJC@MIT-MC|))))~ + ~%~ + ~%(eval-when (compile eval)~ + ~% (or (status feature lispm)~ + ~% (setq *infile-name-key*~ + ~% ((lambda (file-name)~ + ~% ;; temp crock for multics.~ + ~% (cond ((eq (typep file-name) 'list)~ + ~% (namestring file-name))~ + ~% (t file-name)))~ + ~% (truename infile)))))~ + ~%~ + ~%(eval-when (compile)~ + ~% (setq $tr_semicompile '~S)~ + ~% (setq forms-to-compile-queue ()))~ + ~%~%(comment ~S)~%~%" + $tr_semicompile (name-for-printing source)) + (COND ($TRANSCOMPILE + (UPDATE-GLOBAL-DECLARES) + (IF $COMPGRIND + (MFORMAT + TRANSL-FILE + ";;; General declarations required for translated MACSYMA code.~%")) + (PRINT* `(DECLARE . ,DECLARES)))) + +) + +(DEFUN PRINT-ABORT-MSG (FUN FROM) + (MFORMAT *TRANSLATION-MSGS-FILES* + "~:@M failed to Translate.~ + ~%~A will continue, but file output will be aborted." + FUN FROM)) + +(defmacro extension-filename (x) `(caddr (namelist ,x))) + +(DEFUN RENAME-TF (NEW-NAME TRUE-IN-FILE-NAME) + ;; copy the TRANSL-FILE to the file of the new name. + (let ((IN-FILE)) + (UNWIND-PROTECT + (PROGN + (close transl-file) + (SETQ IN-FILE (OPEN-in-dsk (truename TRANSL-FILE))) + (SETQ TRANSL-FILE +;; (OPEN-out-dsk (TRUENAME NEW-NAME))) ;; ejs used to be TRANSL-FILE + (OPEN-out-dsk (TRUENAME TRANSL-FILE))) + (PRINT-TRANSL-HEADER TRUE-IN-FILE-NAME) + (MAPC #'PRINT* (NREVERSE *PRE-TRANSL-FORMS*)) ; clever eh? + (terpri*) + (PUMP-STREAM IN-FILE TRANSL-FILE) + (MFORMAT TRANSL-FILE "~%(compile-forms-to-compile-queue)~%~%") + ;; ejs: added back in + #+ITS + (RENAMEF TRANSL-FILE NEW-NAME) + (DELETEF IN-FILE)) + ;; if something lost... + (IF IN-FILE (CLOSE IN-FILE)) + (IF TRANSL-FILE (CLOSE TRANSL-FILE))))) + + +(DEFUN PUMP-STREAM (IN OUT &optional (n #.(lsh -1 -1))) + (declare (fixnum n)) + (DO ((C)) + ((ZEROP N)) + (DECLARE (FIXNUM C)) + ;; +TYI on ITS doesn't take third argument + (SETQ C #+ITS (+TYI IN) #-ITS (+TYI IN -1)) + (IF (= C -1) (RETURN NIL)) + (+TYO C OUT) + (SETQ N (1- N)))) + + + +(DEFMSPEC $TRANSLATE (FUNCTS) (SETQ FUNCTS (CDR FUNCTS)) + (COND ((AND FUNCTS ($LISTP (CAR FUNCTS))) + (MERROR "Use the function TRANSLATE_FILE")) + (T + (COND ((OR (MEMQ '$FUNCTIONS FUNCTS) + (MEMQ '$ALL FUNCTS)) + (SETQ FUNCTS (MAPCAR 'CAAR (CDR $FUNCTIONS))))) + (DO ((L FUNCTS (CDR L)) + (V NIL)) + ((NULL L) `((MLIST) ,@(NREVERSE V))) + (COND ((ATOM (CAR L)) + (LET ((IT (TRANSLATE-FUNCTION ($VERBIFY (CAR L))))) + (IF IT (PUSH IT V)))) + (T + (TR-TELL + (CAR L) + " is an illegal argument to TRANSLATE."))))))) + +#+LISPM +(PROGN 'COMPILE +(DECLARE (SPECIAL forms-to-compile-queue)) +(DEFMSPEC $COMPILE (FORM) + (LET ((L (MEVAL `(($TRANSLATE),@(CDR FORM))))) + (LET ((forms-to-compile-queue ())) + (MAPC #'(LAMBDA (X) (IF (FBOUNDP X) (COMPILE X))) (CDR L)) + (DO () + ((NULL FORMS-TO-COMPILE-QUEUE) L) + (MAPC #'(LAMBDA (FORM) + (EVAL FORM) + (AND (LISTP FORM) + (EQ (CAR FORM) 'DEFUN) + (SYMBOLP (CADR FORM)) + (COMPILE (CADR FORM)))) + (PROG1 FORMS-TO-COMPILE-QUEUE + (SETQ FORMS-TO-COMPILE-QUEUE NIL))))))) +)