mirror of
https://github.com/PDP-10/its.git
synced 2026-04-29 05:15:47 +00:00
c13cfaca17
backup tapes (90) but with fixes so that it actually works. Previously translate_file failed with version 90. Resolves #1152.
530 lines
16 KiB
Common Lisp
530 lines
16 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- 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)))))))
|
||
)
|