← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/transs.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/transs.lisp
8
8
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module transs)
13
13
 
14
 
(defun set-up-translate ()
15
 
  (load '|<macsym>transl.autolo|)
16
 
  (load '|<macsym>trdata.fasl|)
17
 
  (load '|<maxout>dcl.fasl|)
18
 
  (load '|<macsym>transl.fasl|)
19
 
  (load '|<macsym>trans1.fasl|)
20
 
  (load '|<macsym>troper.fasl|)
21
 
  (load '|<macsym>trutil.fasl|)
22
 
  (load '|<macsym>trans2.fasl|))
23
 
 
24
 
(TRANSL-MODULE TRANSS)
25
 
 
26
 
 
27
 
(DEFMVAR *TRANSL-FILE-DEBUG* NIL
28
 
        "set this to T if you don't want to have the temporary files
 
14
;;(defun set-up-translate ()
 
15
;;  (load '|<macsym>transl.autolo|)
 
16
;;  (load '|<macsym>trdata.fasl|)
 
17
;;  (load '|<maxout>dcl.fasl|)
 
18
;;  (load '|<macsym>transl.fasl|)
 
19
;;  (load '|<macsym>trans1.fasl|)
 
20
;;  (load '|<macsym>troper.fasl|)
 
21
;;  (load '|<macsym>trutil.fasl|)
 
22
;;  (load '|<macsym>trans2.fasl|))
 
23
 
 
24
(transl-module transs)
 
25
 
 
26
 
 
27
(defmvar *transl-file-debug* nil
 
28
  "set this to T if you don't want to have the temporary files
29
29
        used automaticaly deleted in case of errors.")
30
30
 
31
31
;;; User-hacking code, file-io, translator toplevel.
32
32
;;; There are various macros to cons-up filename TEMPLATES
33
 
;;; which to mergef into. The filenames are should be the only
 
33
;;; which to mergef into. The filenames should be the only
34
34
;;; system dependant part of the code, although certain behavior
35
 
;;; of RENAMEF/MERGEF/DELETEF is assumed.
 
35
;;; of RENAMEF/MERGEF/DELETE-FILE is assumed.
36
36
 
37
 
(defmvar $TR_OUTPUT_FILE_DEFAULT '$TRLISP
38
 
         "This is the second file name to be used for translated lisp
 
37
(defmvar $tr_output_file_default '$trlisp
 
38
  "This is the second file name to be used for translated lisp
39
39
         output.")
40
40
 
41
 
(DEFMVAR $TR_FILE_TTY_MESSAGESP nil
42
 
         "It TRUE messages about translation of the file are sent
 
41
(defmvar $tr_file_tty_messagesp nil
 
42
  "It TRUE messages about translation of the file are sent
43
43
         to the TTY also.")
44
44
 
45
 
(DEFMVAR $TR_WINDY T
46
 
         "Generate helpful comments and programming hints.")
47
 
 
48
 
(DEFTRVAR *TRANSLATION-MSGS-FILES* NIL
49
 
        "Where the warning and other comments goes.")
50
 
 
51
 
(DEFTRVAR $TR_VERSION (GET 'TRANSL-AUTOLOAD 'VERSION))
52
 
 
53
 
(DEFMVAR TRANSL-FILE NIL "output stream of $COMPFILE and $TRANSLATE_FILE")
54
 
 
55
 
(DEFMVAR $COMPGRIND NIL "If TRUE lisp output will be pretty-printed.")
56
 
 
57
 
(DEFMVAR $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED nil
58
 
         "This is set by TRANSLATE_FILE for use by user macros
 
45
(defmvar $tr_windy t
 
46
  "Generate helpful comments and programming hints.")
 
47
 
 
48
(deftrvar *translation-msgs-files* nil
 
49
  "Where the warning and other comments goes.")
 
50
 
 
51
(deftrvar $tr_version (get 'transl-autoload 'version))
 
52
 
 
53
(defmvar transl-file nil "output stream of $compfile and $translate_file")
 
54
 
 
55
(defmvar $compgrind nil "If `true' lisp output will be pretty-printed.")
 
56
 
 
57
(defmvar $tr_true_name_of_file_being_translated nil
 
58
  "This is set by TRANSLATE_FILE for use by user macros
59
59
         which want to know the name of the source file.")
60
60
 
61
 
(DEFMVAR $TR_STATE_VARS
62
 
         '((MLIST) $TRANSCOMPILE $TR_SEMICOMPILE
63
 
           #+cl
64
 
           $TRANSLATE_FAST_ARRAYS
65
 
           $TR_WARN_UNDECLARED
66
 
           $TR_WARN_MEVAL
67
 
           $TR_WARN_FEXPR
68
 
           $TR_WARN_MODE
69
 
           $TR_WARN_UNDEFINED_VARIABLE
70
 
           $TR_FUNCTION_CALL_DEFAULT 
71
 
           $TR_ARRAY_AS_REF
72
 
           $TR_NUMER
73
 
           $DEFINE_VARIABLE))
 
61
(defmvar $tr_state_vars
 
62
    '((mlist) $transcompile $tr_semicompile
 
63
      $translate_fast_arrays
 
64
      $tr_warn_undeclared
 
65
      $tr_warn_meval
 
66
      $tr_warn_fexpr
 
67
      $tr_warn_mode
 
68
      $tr_warn_undefined_variable
 
69
      $tr_function_call_default 
 
70
      $tr_array_as_ref
 
71
      $tr_numer
 
72
      $define_variable))
74
73
 
75
74
(defmacro compfile-outputname-temp () 
76
 
;  #-(or Multics Cl) ''|_CMF_ OUTPUT|
77
 
  #+Multics ''(f* _cmf_ output)
78
 
  #+cl '`,(pathname "_cmf_"))
 
75
  '`,(pathname "_cmf_"))
79
76
 
80
77
(defmacro compfile-outputname ()
81
 
  #-(or Multics Cl)'`((DSK ,(STATUS UDIR))
82
 
              ,(STATUS USERID)
83
 
              ,(stripdollar $TR_OUTPUT_FILE_DEFAULT))
84
 
  #+Multics '`(,(status udir) ,(stripdollar $tr_output_file_default))
85
 
  #+cl '`,(pathname (stripdollar $tr_output_file_default)))
 
78
  '`,(pathname (stripdollar $tr_output_file_default)))
86
79
 
87
 
(defmacro trlisp-inputname-d1 ()
88
 
  ;; so hacks on DEFAULTF will not stray the target.
89
 
  #-(or Multics Cl) '`((dsk ,(status udir)) * >)
90
 
  #+Multics '`(,(status udir) * *)
91
 
  #+cl '`,(pathname ""))
 
80
(defmacro trlisp-inputname-d1 () ;; so hacks on DEFAULTF will not
 
81
  '`,(pathname "")) ;; stray the target.
92
82
 
93
83
(defmacro trlisp-outputname-d1 ()
94
 
  #-(or Multics Cl) '`((* *)  * ,(stripdollar $TR_OUTPUT_FILE_DEFAULT))
95
 
  #+Multics '`(* * ,(stripdollar $tr_output_file_default))
96
 
  #+cl '`,(pathname (stripdollar $tr_output_file_default))) 
 
84
  '`,(pathname (stripdollar $tr_output_file_default))) 
97
85
 
98
86
(defmacro trlisp-outputname () 
99
 
;  #-(or Multics Cl) ''|* TRLISP|
100
 
  #+Multics ''(* * lisp)
101
 
  #+cl '`,(make-pathname :type "LISP"))
 
87
  '`,(make-pathname :type "LISP"))
102
88
 
103
89
(defmacro trlisp-outputname-temp ()
104
 
;  #-(or Multics Cl) ''|* _TRLI_|
105
 
  #+Multics ''(* * _trli_)
106
 
  #+cl '`,(pathname "_trli_"))
 
90
  '`,(pathname "_trli_"))
107
91
 
108
92
(defmacro trtags-outputname () 
109
 
;  #-(or Multics Cl) ''|* TAGS|
110
 
  #+Multics ''(* * tags)
111
 
  #+cl '`,(pathname "tags"))
 
93
  '`,(pathname "tags"))
112
94
 
113
95
(defmacro trtags-outputname-temp ()
114
 
;  #-(or Multics Cl) ''|* _TAGS_|
115
 
  #+Multics ''(* * _tags_)
116
 
  #+cl '`,(pathname "_tags_"))
117
 
 
 
96
  '`,(pathname "_tags_"))
118
97
 
119
98
(defmacro trcomments-outputname () 
120
 
;  #-(or Multics Cl) ''|* UNLISP|
121
 
  #+Multics ''(* * unlisp)
122
 
  #+cl '`,(pathname "unlisp"))
 
99
  '`,(pathname "unlisp"))
123
100
 
124
101
(defmacro trcomments-outputname-temp () 
125
 
;  #-(or Multics Cl) ''|* _UNLI_|
126
 
  #+Multics ''(* * _unli_)
127
 
  #+cl '`,(pathname "_unli_"))
128
 
 
129
 
(DEFTRVAR DECLARES NIL)
 
102
  '`,(pathname "_unli_"))
 
103
 
 
104
(deftrvar declares nil)
 
105
 
130
106
;;;these first five functions have been altered to run on 
131
107
;;;the 3600 we must try to fix translate-file  wfs fixed -wfs
132
 
#+cl
133
 
(defmacro mytruename (x) `(truename ,x))
134
 
 
135
 
 
136
 
#+cl    
 
108
 
137
109
(defun rename-tf (new-name true-in-file-name &optional newname)
138
 
   true-in-file-name  new-name
 
110
  true-in-file-name  new-name
139
111
  (let ((in-file))
140
112
    (progn
141
113
      (setq in-file (truename transl-file))
142
114
      (close transl-file)
143
 
      (setq newname (sub-seq (string newname) 1))
 
115
      (setq newname (maxima-string newname))
144
116
      (rename-file in-file newname))))
145
117
 
146
 
        
147
 
#+CL
148
 
(DEFMSPEC $COMPFILE (FORMS)
 
118
(defmspec $compfile (forms)
149
119
  (let (( newname (second  forms)))
150
 
  (setq forms (cdr forms))
151
 
  (bind-transl-state
152
 
   (SETQ $TRANSCOMPILE T
153
 
         *IN-COMPFILE* T)
154
 
   (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS))
155
 
                               ($FILENAME_MERGE (POP FORMS)))
156
 
                              (T "")))
157
 
         (t-error nil)
158
 
         (*TRANSLATION-MSGS-FILES* NIL))
159
 
     (SETQ OUT-FILE-NAME
160
 
           (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME)))
161
 
     (UNWIND-PROTECT
162
 
      (PROGN
163
 
       (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP)
164
 
                                               OUT-FILE-NAME)))
165
 
 
166
 
       (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS))
167
 
              (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS)))))
168
 
       (DO ((L FORMS (CDR L)) 
169
 
            (DECLARES NIL NIL)
170
 
            (TR-ABORT NIL NIL)
171
 
            (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL)
172
 
            (T-ITEM))                           ;
173
 
           ((NULL L))
174
 
         (SETQ ITEM (CAR L))
175
 
         (COND ((NOT (ATOM ITEM))
176
 
                (PRINT* (DCONVX (TRANSLATE ITEM))))
177
 
               (T
178
 
                (SETQ T-ITEM
179
 
                      (COMPILE-FUNCTION
180
 
                       (SETQ ITEM ($VERBIFY ITEM))))
181
 
                (COND (TR-ABORT
182
 
                       (SETQ T-ERROR
183
 
                             (PRINT-ABORT-MSG ITEM
184
 
                                              'COMPFILE)))
185
 
                      (T
186
 
                       (COND ($COMPGRIND
187
 
                              (MFORMAT TRANSL-FILE
188
 
                                       "~2%;; Function ~:@M~%" ITEM)))
189
 
                       (PRINT* T-ITEM))))))
190
 
       (setq out-file-name (RENAME-TF OUT-FILE-NAME NIL newname))
191
 
       (TO-MACSYMA-NAMESTRING OUT-FILE-NAME))
192
 
      ;; unwind-protected
193
 
      (IF TRANSL-FILE (CLOSE TRANSL-FILE))
194
 
      (IF T-ERROR (DELETEF TRANSL-FILE)))))))
195
 
#-cl
196
 
 
197
 
(DEFMSPEC $COMPFILE (FORMS) (setq forms (cdr forms))
198
 
  (bind-transl-state
199
 
   (SETQ $TRANSCOMPILE T
200
 
         *IN-COMPFILE* T)
201
 
   (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS))
202
 
                               ($FILENAME_MERGE (POP FORMS)))
203
 
                              (T "")))
204
 
         (t-error nil)
205
 
         (*TRANSLATION-MSGS-FILES* NIL))
206
 
     (SETQ OUT-FILE-NAME
207
 
           (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME)))
208
 
     (UNWIND-PROTECT
209
 
      (PROGN
210
 
       (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP)
211
 
                                               OUT-FILE-NAME)))
212
 
 
213
 
       (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS))
214
 
              (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS)))))
215
 
       (DO ((L FORMS (CDR L)) 
216
 
            (DECLARES NIL NIL)
217
 
            (TR-ABORT NIL NIL)
218
 
            (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL)
219
 
            (T-ITEM))
220
 
           ((NULL L))
221
 
         (SETQ ITEM (CAR L))
222
 
         (COND ((NOT (ATOM ITEM))
223
 
                (PRINT* (DCONVX (TRANSLATE ITEM))))
224
 
               (T
225
 
                (SETQ T-ITEM
226
 
                      (COMPILE-FUNCTION
227
 
                       (SETQ ITEM ($VERBIFY ITEM))))
228
 
                (COND (TR-ABORT
229
 
                       (SETQ T-ERROR
230
 
                             (PRINT-ABORT-MSG ITEM
231
 
                                              'COMPFILE)))
232
 
                      (T
233
 
                       (COND ($COMPGRIND
234
 
                              (MFORMAT TRANSL-FILE
235
 
                                       "~2%;; Function ~:@M~%" ITEM)))
236
 
                       (PRINT* T-ITEM))))))
237
 
       (RENAME-TF OUT-FILE-NAME NIL)
238
 
       (TO-MACSYMA-NAMESTRING OUT-FILE-NAME))
239
 
      ;; unwind-protected
240
 
      (IF TRANSL-FILE (CLOSE TRANSL-FILE))
241
 
      (IF T-ERROR (DELETEF TRANSL-FILE))))))
242
 
 
243
 
 
244
 
(DEFUN COMPILE-FUNCTION (F)
245
 
       (MFORMAT  *TRANSLATION-MSGS-FILES*
246
 
                 "~%Translating ~:@M" F)
247
 
       (LET ((FUN (TR-MFUN F)))
248
 
            (COND (TR-ABORT  NIL)
249
 
                  (T FUN))))
250
 
 
251
 
(DEFVAR TR-DEFAULTF NIL
252
 
        "A default only for the case of NO arguments to $TRANSLATE_FILE")
 
120
    (setq forms (cdr forms))
 
121
    (bind-transl-state
 
122
     (setq $transcompile t
 
123
           *in-compfile* t)
 
124
     (let ((out-file-name (cond ((mfilename-onlyp (car forms))
 
125
                                 ($filename_merge (pop forms)))
 
126
                                (t "")))
 
127
           (t-error nil)
 
128
           (*translation-msgs-files* nil))
 
129
       (setq out-file-name
 
130
             (mergef out-file-name (compfile-outputname)))
 
131
       (unwind-protect
 
132
            (progn
 
133
              (setq transl-file (open-out-dsk (mergef (compfile-outputname-temp)
 
134
                                                      out-file-name)))
 
135
 
 
136
              (cond ((or (memq '$all forms) (memq '$functions forms))
 
137
                     (setq forms (mapcar #'caar (cdr $functions)))))
 
138
              (do ((l forms (cdr l)) 
 
139
                   (declares nil nil)
 
140
                   (tr-abort nil nil)
 
141
                   (item) (lexprs nil nil) (fexprs nil nil)
 
142
                   (t-item))            ;
 
143
                  ((null l))
 
144
                (setq item (car l))
 
145
                (cond ((not (atom item))
 
146
                       (print* (dconvx (translate item))))
 
147
                      (t
 
148
                       (setq t-item
 
149
                             (compile-function
 
150
                              (setq item ($verbify item))))
 
151
                       (cond (tr-abort
 
152
                              (setq t-error
 
153
                                    (print-abort-msg item
 
154
                                                     'compfile)))
 
155
                             (t
 
156
                              (cond ($compgrind
 
157
                                     (mformat transl-file
 
158
                                              "~2%;; Function ~:@M~%" item)))
 
159
                              (print* t-item))))))
 
160
              (setq out-file-name (rename-tf out-file-name nil newname))
 
161
              (to-macsyma-namestring out-file-name))
 
162
         ;; unwind-protected
 
163
         (if transl-file (close transl-file))
 
164
         (if t-error (delete-file transl-file)))))))
 
165
 
 
166
;;#-cl
 
167
;;(DEFMSPEC $COMPFILE (FORMS) (setq forms (cdr forms))
 
168
;;  (bind-transl-state
 
169
;;   (SETQ $TRANSCOMPILE T
 
170
;;       *IN-COMPFILE* T)
 
171
;;   (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS))
 
172
;;                             ($FILENAME_MERGE (POP FORMS)))
 
173
;;                            (T "")))
 
174
;;       (t-error nil)
 
175
;;       (*TRANSLATION-MSGS-FILES* NIL))
 
176
;;     (SETQ OUT-FILE-NAME
 
177
;;         (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME)))
 
178
;;     (UNWIND-PROTECT
 
179
;;      (PROGN
 
180
;;       (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP)
 
181
;;                                             OUT-FILE-NAME)))
 
182
 
 
183
;;       (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS))
 
184
;;            (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS)))))
 
185
;;       (DO ((L FORMS (CDR L)) 
 
186
;;          (DECLARES NIL NIL)
 
187
;;          (TR-ABORT NIL NIL)
 
188
;;          (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL)
 
189
;;          (T-ITEM))
 
190
;;         ((NULL L))
 
191
;;       (SETQ ITEM (CAR L))
 
192
;;       (COND ((NOT (ATOM ITEM))
 
193
;;              (PRINT* (DCONVX (TRANSLATE ITEM))))
 
194
;;             (T
 
195
;;              (SETQ T-ITEM
 
196
;;                    (COMPILE-FUNCTION
 
197
;;                     (SETQ ITEM ($VERBIFY ITEM))))
 
198
;;              (COND (TR-ABORT
 
199
;;                     (SETQ T-ERROR
 
200
;;                           (PRINT-ABORT-MSG ITEM
 
201
;;                                            'COMPFILE)))
 
202
;;                    (T
 
203
;;                     (COND ($COMPGRIND
 
204
;;                            (MFORMAT TRANSL-FILE
 
205
;;                                     "~2%;; Function ~:@M~%" ITEM)))
 
206
;;                     (PRINT* T-ITEM))))))
 
207
;;       (RENAME-TF OUT-FILE-NAME NIL)
 
208
;;       (TO-MACSYMA-NAMESTRING OUT-FILE-NAME))
 
209
;;      ;; unwind-protected
 
210
;;      (IF TRANSL-FILE (CLOSE TRANSL-FILE))
 
211
;;      (IF T-ERROR (DELETE-FILE TRANSL-FILE))))))
 
212
 
 
213
 
 
214
(defun compile-function (f)
 
215
  (mformat  *translation-msgs-files*
 
216
            "~%Translating ~:@M" f)
 
217
  (let ((fun (tr-mfun f)))
 
218
    (cond (tr-abort  nil)
 
219
          (t fun))))
 
220
 
 
221
(defvar tr-defaultf nil
 
222
  "A default only for the case of no arguments to $translate_file")
253
223
 
254
224
;;; Temporary hack during debugging of this  code.
255
 
#+cl
 
225
 
256
226
(progn 'compile
257
 
#-cl
258
 
(defun mergef (x y) (fs:merge-pathnames y x))
259
 
#+cl
260
 
(defun mergef (x y) (merge-pathnames y x))
261
 
#-cl
262
 
(defmacro truename (x) `(send ,x ':truename)))
 
227
       (defun mergef (x y) (merge-pathnames y x)))
263
228
 
264
229
(defun $compile_file (input-file
265
230
                      &optional bin-file  translation-output-file &aux result )
271
236
         (setq result (list '(mlist) input-file)))
272
237
        (t (setq result (translate-file input-file translation-output-file))
273
238
           (setq input-file (third result))))
274
 
  #+(or cmu sbcl clisp allegro openmcl)
 
239
  #+(or cmu scl sbcl clisp allegro openmcl)
275
240
  (multiple-value-bind (output-truename warnings-p failure-p)
276
241
      (if bin-file
277
242
          (compile-file input-file :output-file bin-file)
278
243
          (compile-file input-file))
 
244
    (declare (ignore warnings-p))
279
245
    ;; If the compiler encountered errors, don't set bin-file to
280
246
    ;; indicate that we found errors. Is this what we want?
281
247
    (unless failure-p
282
248
      (setq bin-file output-truename)))
283
 
  #-(or cmu sbcl clisp allegro openmcl)
 
249
  #-(or cmu scl sbcl clisp allegro openmcl)
284
250
  (setq bin-file (compile-file input-file :output-file bin-file))
285
251
  (append result (list bin-file)))
286
252
 
287
 
#-cl
288
 
(DEFMFUN $TRANSLATE_FILE (&OPTIONAL (INPUT-FILE-NAME NIL I-P)
289
 
                                    (OUTPUT-FILE-NAME NIL O-P))
290
 
         #+cl
291
 
         (progn (cond ((atom input-file-name)
292
 
                       (setq input-file-name
293
 
                             (string-trim "&" input-file-name)))))
294
 
         (OR I-P TR-DEFAULTF
295
 
             (MERROR "Arguments are input file and optional output file~
296
 
                     ~%which defaults to second name LISP, msgs are put~
297
 
                     ~%in file with second file name UNLISP"))
298
 
         (COND (I-P
299
 
                #+cl(SETQ INPUT-FILE-NAME
300
 
                             (pathname
301
 
                               input-file-name))
302
 
                #-cl
303
 
                (SETQ INPUT-FILE-NAME (MERGEF ($FILENAME_MERGE INPUT-FILE-NAME)
304
 
                                              (trlisp-inputname-d1)))
305
 
                (SETQ TR-DEFAULTF INPUT-FILE-NAME))
306
 
               (T
307
 
                (SETQ TR-DEFAULTF INPUT-FILE-NAME)))
308
 
         #+cl
309
 
         (SETQ OUTPUT-FILE-NAME
310
 
               (progn (setq output-file-name
311
 
                            (pathname
312
 
                              (if o-p output-file-name input-file-name)))
313
 
                      (send output-file-name :new-type :lisp)))
314
 
         #-cl
315
 
         (SETQ OUTPUT-FILE-NAME
316
 
               (IF O-P
317
 
                   (MERGEF ($FILENAME_MERGE OUTPUT-FILE-NAME) INPUT-FILE-NAME)
318
 
                   (MERGEF (TRLISP-OUTPUTNAME-D1) INPUT-FILE-NAME)))
319
 
         (TRANSLATE-FILE  INPUT-FILE-NAME
320
 
                          OUTPUT-FILE-NAME
321
 
                          $TR_FILE_TTY_MESSAGESP ))
 
253
;;#-cl
 
254
;;(DEFMFUN $TRANSLATE_FILE (&OPTIONAL (INPUT-FILE-NAME NIL I-P)
 
255
;;                                  (OUTPUT-FILE-NAME NIL O-P))
 
256
;;       #+cl
 
257
;;       (progn (cond ((atom input-file-name)
 
258
;;                     (setq input-file-name
 
259
;;                           (string-trim "&" input-file-name)))))
 
260
;;       (OR I-P TR-DEFAULTF
 
261
;;           (MERROR "Arguments are input file and optional output file~
 
262
;;                   ~%which defaults to second name LISP, msgs are put~
 
263
;;                   ~%in file with second file name UNLISP"))
 
264
;;       (COND (I-P
 
265
;;              #+cl(SETQ INPUT-FILE-NAME
 
266
;;                           (pathname
 
267
;;                             input-file-name))
 
268
;;              #-cl
 
269
;;              (SETQ INPUT-FILE-NAME (MERGEF ($FILENAME_MERGE INPUT-FILE-NAME)
 
270
;;                                            (trlisp-inputname-d1)))
 
271
;;              (SETQ TR-DEFAULTF INPUT-FILE-NAME))
 
272
;;             (T
 
273
;;              (SETQ TR-DEFAULTF INPUT-FILE-NAME)))
 
274
;;       #+cl
 
275
;;       (SETQ OUTPUT-FILE-NAME
 
276
;;             (progn (setq output-file-name
 
277
;;                          (pathname
 
278
;;                            (if o-p output-file-name input-file-name)))
 
279
;;                    (send output-file-name :new-type :lisp)))
 
280
;;       #-cl
 
281
;;       (SETQ OUTPUT-FILE-NAME
 
282
;;             (IF O-P
 
283
;;                 (MERGEF ($FILENAME_MERGE OUTPUT-FILE-NAME) INPUT-FILE-NAME)
 
284
;;                 (MERGEF (TRLISP-OUTPUTNAME-D1) INPUT-FILE-NAME)))
 
285
;;       (TRANSLATE-FILE  INPUT-FILE-NAME
 
286
;;                        OUTPUT-FILE-NAME
 
287
;;                        $TR_FILE_TTY_MESSAGESP ))
322
288
 
323
 
#+cl
 
289
;; Converts a Maxima "string" (which is really a symbol that starts
 
290
;; with the character '&') to a Lisp string.
324
291
(defun maxima-string (symb)
325
 
  (string-left-trim "&" (string symb)))
 
292
  (string-left-trim "&" (print-invert-case symb)))
326
293
 
327
 
#+cl
328
294
(defmfun $translate_file (input-file &optional output-file)
329
 
      (setq input-file (maxima-string input-file))
330
 
      (cond (output-file (setq output-file (maxima-string output-file))))
331
 
      (translate-file input-file output-file))
 
295
  (setq input-file (maxima-string input-file))
 
296
  (cond (output-file (setq output-file (maxima-string output-file))))
 
297
  (translate-file input-file output-file))
332
298
 
333
 
(DEFMVAR $TR_GEN_TAGS NIL
334
 
         "If TRUE, TRANSLATE_FILE generates a TAGS file for
 
299
(defmvar $tr_gen_tags nil
 
300
  "If TRUE, TRANSLATE_FILE generates a TAGS file for
335
301
         use by the text editor")
336
302
 
337
303
(defvar *pretty-print-translation* t)
338
 
#+cl
 
304
 
 
305
;; Define a pprinter for defmtrfun.
 
306
 
 
307
#-gcl
 
308
(defun pprint-defmtrfun (stream s)
 
309
  (pprint-logical-block (stream s :prefix "(" :suffix ")")
 
310
    (write (pprint-pop) :stream stream)
 
311
    (write-char #\space stream)
 
312
    (write (pprint-pop) :stream stream)
 
313
    (pprint-indent :block 4 stream)
 
314
    (pprint-newline :mandatory stream)
 
315
    (write (pprint-pop) :stream stream)
 
316
    (pprint-indent :block 2 stream)
 
317
    (pprint-newline :mandatory stream)
 
318
    (loop
 
319
       (pprint-exit-if-list-exhausted)
 
320
       (write (pprint-pop) :stream stream)
 
321
       (write-char #\space stream)
 
322
       (pprint-newline :linear stream))))
 
323
 
339
324
(defun call-batch1 (in-stream out-stream &aux expr transl)
340
325
  (cleanup)
341
326
  ;; we want the thing to start with a newline..
342
327
  (newline in-stream #\n)
343
 
  (sloop while (and (setq  expr   (mread in-stream))
344
 
                   (consp expr))
345
 
        do (setq transl (translate-macexpr-toplevel (third expr)))
346
 
        (cond (*pretty-print-translation* (pprint transl out-stream))
347
 
              (t
348
 
               (format out-stream  "~A" transl)))))
 
328
  (let ((*readtable* (copy-readtable nil))
 
329
        #-gcl
 
330
        (*print-pprint-dispatch* (copy-pprint-dispatch)))
 
331
    #-gcl
 
332
    (progn
 
333
      #-(or scl allegro)
 
334
      (setf (readtable-case *readtable*) :invert)
 
335
      #+(or scl allegro)
 
336
      (unless #+scl (eq ext:*case-mode* :lower)
 
337
              #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)
 
338
        (setf (readtable-case *readtable*) :invert))
 
339
      (set-pprint-dispatch '(cons (member maxima::defmtrfun))
 
340
                           #'pprint-defmtrfun))
 
341
    (loop while (and (setq expr (mread in-stream)) (consp expr))
 
342
          do (setq transl (translate-macexpr-toplevel (third expr)))
 
343
             (cond
 
344
               (*pretty-print-translation*
 
345
                (pprint transl out-stream))
 
346
               (t
 
347
                (format out-stream "~a" transl))))))
349
348
 
350
349
 
351
350
(defun translate-from-stream (from-stream &key to-stream eval pretty (print-function #'prin1) &aux expr transl )
352
351
  (bind-transl-state                    
353
 
  (sloop while (and (setq expr (mread from-stream)) (consp expr))
354
 
        with *in-translate-file* = t
355
 
        with *print-pretty* = pretty
356
 
        do (setq transl (translate-macexpr-toplevel (third expr)))
357
 
        ;(show transl  forms-to-compile-queue)
358
 
        (cond (eval (eval transl)))
359
 
        (cond (to-stream (funcall print-function transl to-stream)))
360
 
        (sloop for v in forms-to-compile-queue
361
 
              do (show v to-stream)
362
 
              when to-stream
363
 
              do (funcall print-function v to-stream)
364
 
              when eval
365
 
              do (eval v)
366
 
              )
367
 
        (setq forms-to-compile-queue nil))))
368
 
 
369
 
(DEFVAR TRF-START-HOOK NIL)
370
 
 
371
 
#+cl
372
 
(DEFUN DELETE-OLD-AND-OPEN (X)
373
 
    (open x :direction :output))
374
 
#-cl
375
 
(DEFUN DELETE-OLD-AND-OPEN (X)
376
 
       (IF (LET ((F (PROBE-FILE X)))
377
 
                (AND F (NOT (MEMQ (CADDR (NAMELIST F)) '(< >)))))
378
 
           (DELETEF X))
379
 
       (OPEN-OUT-DSK X))
380
 
 
381
 
#+cl
 
352
   (loop while (and (setq expr (mread from-stream)) (consp expr))
 
353
          with *in-translate-file* = t
 
354
          with *print-pretty* = pretty
 
355
          do (setq transl (translate-macexpr-toplevel (third expr)))
 
356
                                        ;(show transl  forms-to-compile-queue)
 
357
          (cond (eval (eval transl)))
 
358
          (cond (to-stream (funcall print-function transl to-stream)))
 
359
          (loop for v in forms-to-compile-queue
 
360
                 do (show v to-stream)
 
361
                 when to-stream
 
362
                 do (funcall print-function v to-stream)
 
363
                 when eval
 
364
                 do (eval v)
 
365
                 )
 
366
          (setq forms-to-compile-queue nil))))
 
367
 
 
368
(defvar trf-start-hook nil)
 
369
 
 
370
(defun delete-old-and-open (x)
 
371
  (open x :direction :output))
 
372
 
 
373
;;#-cl
 
374
;;(DEFUN DELETE-OLD-AND-OPEN (X)
 
375
;;       (IF (LET ((F (PROBE-FILE X)))
 
376
;;              (AND F (NOT (MEMQ (CADDR (NAMELIST F)) '(< >)))))
 
377
;;         (DELETE-FILE X))
 
378
;;       (OPEN-OUT-DSK X))
 
379
 
382
380
(defun alter-pathname (pathname &rest options)
383
 
  (apply 'make-pathname :defaults (pathname  pathname)  options))
 
381
  (apply 'make-pathname :defaults (pathname  pathname) options))
384
382
 
385
383
(defun delete-with-side-effects-if (test list)
386
 
  (declare (function test))
387
384
  "Rudimentary DELETE-IF which, however, is guaranteed to call
388
385
the function TEST exactly once for each element of LIST, from
389
386
left to right."
390
387
  (loop
391
 
     while (and list (funcall test (car list)))
392
 
     do (pop list))
 
388
   while (and list (funcall test (car list)))
 
389
   do (pop list))
393
390
  (loop
394
 
     with list = list
395
 
     while (cdr list)
396
 
     if (funcall test (cadr list))
397
 
     do (pop (cdr list))
398
 
     else
399
 
     do (pop list))
 
391
   with list = list
 
392
   while (cdr list)
 
393
   if (funcall test (cadr list))
 
394
   do (pop (cdr list))
 
395
   else
 
396
   do (pop list))
400
397
  list)
401
398
 
402
399
(defun insert-necessary-function-declares (stream)
436
433
      (format stream "$ */"))
437
434
    (fresh-line stream)
438
435
    (when (or hint *untranslated-functions-called*)
439
 
      (format t "~&See the UNLISP file for possible optimizations."))))
440
 
 
441
 
 
442
 
#+cl
443
 
(DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME
444
 
                                    &optional
445
 
                                    (TTYMSGSP  $TR_FILE_TTY_MESSAGESP) &aux  warn-file
446
 
                                    translated-file
447
 
                                    *translation-msgs-files* *untranslated-functions-called* *declared-translated-functions*)
448
 
  (BIND-TRANSL-STATE
449
 
    (SETQ *IN-TRANSLATE-FILE* T)
450
 
    (setq translated-file (alter-pathname (or out-file-name in-file-name) :type "LISP"))
451
 
    (setq warn-file (alter-pathname in-file-name :type "UNLISP"))
452
 
    (with-open-file (in-stream in-file-name)
453
 
      (with-open-file (out-stream translated-file :direction :output
454
 
                                  :if-exists :supersede)
455
 
        (with-open-file (warn-stream warn-file :direction :output
456
 
                                     :if-exists :supersede)
457
 
              (setq *translation-msgs-files* (list warn-stream))
458
 
          (IF TTYMSGSP
459
 
              (SETQ *TRANSLATION-MSGS-FILES*
460
 
                    (CONS *standard-output* *TRANSLATION-MSGS-FILES*)))
461
 
          (format out-stream
462
 
  ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp ;Base: 10 -*- ;;;~%")
463
 
          #+lispm
464
 
          (format out-stream ";;;Translated on: ~A"
465
 
                  (time:print-current-time nil))
466
 
          #+lispm
467
 
          (format out-stream
468
 
                  ";;Maxima System version ~A"
469
 
                  (or (si:get-system-version 'maxima)
470
 
                      (si:get-system-version 'cl-maxima)))
471
 
          #+cl (format out-stream "~%(in-package \"MAXIMA\")")
472
 
          (format warn-stream "~%This is the unlisp file for ~A "
473
 
           (namestring (pathname in-stream)))
474
 
          (MFORMAT out-stream
475
 
                   "~%;;** Variable settings were **~%~%")
476
 
          (sloop for v in (cdr $tr_state_vars)
477
 
                do (mformat out-stream   ";;~:M:~:M;~%" v (symbol-value v)))
478
 
          (MFORMAT *terminal-io* "~%Translation begun on ~A.~%"
479
 
                   (pathname in-stream))
480
 
          (CALL-BATCH1 in-stream out-stream)
481
 
          (insert-necessary-function-declares warn-stream)
482
 
          ;; BATCH1 calls TRANSLATE-MACEXPR-toplevel on each expression read.
483
 
          (cons '(mlist) 
484
 
                (mapcar 'namestring
485
 
                (mapcar 'pathname
486
 
                        (list in-stream out-stream warn-stream)))))))))
487
 
 
488
 
 
489
 
#-cl 
490
 
(DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME TTYMSGSP)
491
 
  (BIND-TRANSL-STATE
492
 
   (SETQ *IN-TRANSLATE-FILE* T)
493
 
   (LET ((IN-FILE)
494
 
         (*TRANSLATION-MSGS-FILES*)
495
 
         (DSK-MSGS-FILE)
496
 
         (TAGS-OUTPUT-STREAM)
497
 
         (TAGS-OUTPUT-STREAM-STATE)
498
 
         (WINP NIL)
499
 
         (TRUE-IN-FILE-NAME))
500
 
     (UNWIND-PROTECT
501
 
      (PROGN
502
 
       (SETQ IN-FILE  (OPEN IN-FILE-NAME)
503
 
             TRUE-IN-FILE-NAME (TO-MACSYMA-NAMESTRING (TRUENAME IN-FILE))
504
 
             $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED TRUE-IN-FILE-NAME
505
 
             TRANSL-FILE (DELETE-OLD-AND-OPEN
506
 
                          (MERGEF (trlisp-outputname-temp)
507
 
                                  OUT-FILE-NAME))
508
 
             DSK-MSGS-FILE (DELETE-OLD-AND-OPEN
509
 
                            #+cl
510
 
                             (merge-pathnames out-file-name
511
 
                                              (make-pathname :type "unlisp"))
512
 
                             #-cl(MERGEF (trcomments-outputname-temp)
513
 
                                    OUT-FILE-NAME)
514
 
                             )
515
 
             *TRANSLATION-MSGS-FILES* (LIST DSK-MSGS-FILE))
516
 
       (IF $TR_GEN_TAGS
517
 
           (SETQ TAGS-OUTPUT-STREAM
518
 
                 (OPEN-out-dsk (MERGEF (trtags-outputname-temp)
519
 
                                       IN-FILE-NAME))))
520
 
       (IF TTYMSGSP
521
 
           (SETQ *TRANSLATION-MSGS-FILES*
522
 
                 (CONS #-cl TYO #+cl *standard-output* *TRANSLATION-MSGS-FILES*)))
523
 
        #-cl(PROGN(CLOSE IN-FILE)
524
 
              ;; IN-FILE stream of no use with old-io BATCH1.
525
 
               (SETQ IN-FILE NIL))
526
 
       (MFORMAT DSK-MSGS-FILE "~%This is the UNLISP file for ~A.~%"
527
 
                TRUE-IN-FILE-NAME)
528
 
       (MFORMAT *terminal-io* "~%Translation begun on ~A.~%"
529
 
                TRUE-IN-FILE-NAME)
530
 
       (IF TRF-START-HOOK (FUNCALL TRF-START-HOOK TRUE-IN-FILE-NAME))
531
 
       #-cl
532
 
       (IF TAGS-OUTPUT-STREAM (TAGS-START//END IN-FILE-NAME))
533
 
       (CALL-BATCH1 in-file transl-file)
534
 
       ;; BATCH1 calls TRANSLATE-MACEXPR on each expression read.
535
 
       (MFORMAT DSK-MSGS-FILE
536
 
                "~%//* Variable settings were *//~%~%")
537
 
       (DO ((L (CDR $TR_STATE_VARS) (CDR L)))
538
 
           ((NULL L))
539
 
         (MFORMAT-OPEN DSK-MSGS-FILE
540
 
                       "~:M:~:M;~%"
541
 
                       (CAR L) (SYMBOL-VALUE (CAR L))))
542
 
       #-cl(RENAME-TF OUT-FILE-NAME TRUE-IN-FILE-NAME)
543
 
       #-cl       (WHEN TAGS-OUTPUT-STREAM
544
 
             (TAGS-START//END)
545
 
             ;;(CLOSE TAGS-OUTPUT-STREAM) 
546
 
             (RENAMEF TAGS-OUTPUT-STREAM (trtags-outputname)))
547
 
       ;;(CLOSE DSK-MSGS-FILE)
548
 
       ;; The CLOSE before RENAMEF clobbers the old temp file.
549
 
       ;; nope. you get a FILE-ALREADY-EXISTS error. darn.
550
 
       (let ((tr-comment-file-name (mergef (trcomments-outputname)
551
 
                                   out-file-name)))
552
 
         #-cl (if (probe-file tr-comment-file-name)
553
 
                     (deletef tr-comment-file-name))
554
 
        #-cl (RENAMEF DSK-MSGS-FILE tr-comment-file-name)
555
 
       (SETQ WINP T)
556
 
       #-cl`((MLIST) ,(TO-MACSYMA-NAMESTRING TRUE-IN-FILE-NAME)
557
 
                 ,(TO-MACSYMA-NAMESTRING OUT-FILE-NAME)
558
 
                 ,(TO-MACSYMA-NAMESTRING (TRUENAME tr-comment-file-name))
559
 
                 ,@(IF TAGS-OUTPUT-STREAM
560
 
                       (LIST (TO-MACSYMA-NAMESTRING
561
 
                              (TRUENAME TAGS-OUTPUT-STREAM)))
562
 
                       NIL))
563
 
      #+cl `((mlist) ,(send in-file :truename)
564
 
                ,(send transl-file :truename)
565
 
                ,(send dsk-msgs-file :truename))))
566
 
      ;; Unwind protected. 
567
 
      (IF DSK-MSGS-FILE (CLOSE DSK-MSGS-FILE))
568
 
      (IF TRANSL-FILE   (CLOSE TRANSL-FILE))
569
 
      (if in-file  (close in-file))
570
 
      (IF TAGS-OUTPUT-STREAM (CLOSE TAGS-OUTPUT-STREAM))
571
 
      (WHEN (AND (NOT WINP) (NOT *TRANSL-FILE-DEBUG*))
572
 
            (IF TAGS-OUTPUT-STREAM (DELETEF TAGS-OUTPUT-STREAM))
573
 
            (IF TRANSL-FILE (DELETEF TRANSL-FILE)))))))
574
 
 
575
 
 
576
 
 
577
 
;; Should be rewritten to use streams.  Barf -- perhaps SPRINTER doesn't take
578
 
;; a stream argument? Yes Carl SPRINTER is old i/o, but KMP is writing
579
 
;; a new one for NIL.  -GJC
580
 
 
581
 
(DEFUN PRINT* (P)
582
 
  (LET ((^W T)
583
 
        (OUTFILES (LIST TRANSL-FILE))
584
 
        (^R T)
585
 
        #-cl(*NOPOINT NIL)
586
 
        ($LOADPRINT NIL)) ;;; lusing old I/O !!!!!
587
 
       (declare (special OUTFILES))
588
 
    (SUB-PRINT* P)))
 
436
      (format t "~&See the `unlisp' file for possible optimizations.~%"))))
 
437
 
 
438
 
 
439
(defun translate-file (in-file-name out-file-name
 
440
                       &optional
 
441
                       (ttymsgsp  $tr_file_tty_messagesp) &aux  warn-file
 
442
                       translated-file
 
443
                       *translation-msgs-files* *untranslated-functions-called* *declared-translated-functions*)
 
444
  (bind-transl-state
 
445
   (setq *in-translate-file* t)
 
446
   (setq translated-file (alter-pathname (or out-file-name in-file-name) :type "LISP"))
 
447
   (setq warn-file (alter-pathname in-file-name :type "UNLISP"))
 
448
   (with-open-file (in-stream in-file-name)
 
449
     (with-open-file (out-stream translated-file :direction :output
 
450
                                 :if-exists :supersede)
 
451
       (with-open-file (warn-stream warn-file :direction :output
 
452
                                    :if-exists :supersede)
 
453
         (setq *translation-msgs-files* (list warn-stream))
 
454
         (if ttymsgsp
 
455
             (setq *translation-msgs-files*
 
456
                   (cons *standard-output* *translation-msgs-files*)))
 
457
         (format out-stream
 
458
                 ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp ;Base: 10 -*- ;;;~%")
 
459
 
 
460
         (flet ((timezone-iso8601-name (dst tz)
 
461
                  ;; This function was borrowed from CMUCL.
 
462
                  (let ((tz (- tz)))
 
463
                    (if (and (not dst) (= tz 0))
 
464
                        "Z"
 
465
                        (multiple-value-bind (hours minutes)
 
466
                            (truncate (if dst (1+ tz) tz))
 
467
                          (format nil "~C~2,'0D:~2,'0D"
 
468
                                  (if (minusp tz) #\- #\+)
 
469
                                  (abs hours)
 
470
                                  (abs (truncate (* minutes 60)))))))))
 
471
 
 
472
           (multiple-value-bind (secs mins hours day month year dow dst tz)
 
473
               (decode-universal-time (get-universal-time))
 
474
             (declare (ignore dow))
 
475
             (format out-stream ";;; Translated on: ~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~A~%"
 
476
                     year month day hours mins secs (timezone-iso8601-name dst tz))))
 
477
         (format out-stream ";;; Maxima System version: ~A~%" *autoconf-version*)
 
478
         (format out-stream ";;; Lisp type:    ~A~%" (lisp-implementation-type))
 
479
         (format out-stream ";;; Lisp version: ~A~%" (lisp-implementation-version))
 
480
         ;;       #+lispm
 
481
         ;;       (format out-stream
 
482
         ;;               ";;Maxima System version ~A"
 
483
         ;;               (or (si:get-system-version 'maxima)
 
484
         ;;                   (si:get-system-version 'cl-maxima)))
 
485
         (format out-stream "~%(in-package :maxima)")
 
486
         (format warn-stream "~%This is the unlisp file for ~A "
 
487
                 (namestring (pathname in-stream)))
 
488
         (mformat out-stream
 
489
                  "~%;;** Variable settings were **~%~%")
 
490
         (loop for v in (cdr $tr_state_vars)
 
491
                do (mformat out-stream   ";; ~:M: ~:M;~%" v (symbol-value v)))
 
492
         (mformat *terminal-io* "~%Translation begun on ~A.~%"
 
493
                  (pathname in-stream))
 
494
         (call-batch1 in-stream out-stream)
 
495
         (insert-necessary-function-declares warn-stream)
 
496
         ;; BATCH1 calls TRANSLATE-MACEXPR-toplevel on each expression read.
 
497
         (cons '(mlist) 
 
498
               (mapcar 'namestring
 
499
                       (mapcar 'pathname
 
500
                               (list in-stream out-stream warn-stream)))))))))
 
501
 
 
502
 
 
503
;;#-cl 
 
504
;;(DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME TTYMSGSP)
 
505
;;  (BIND-TRANSL-STATE
 
506
;;   (SETQ *IN-TRANSLATE-FILE* T)
 
507
;;   (LET ((IN-FILE)
 
508
;;       (*TRANSLATION-MSGS-FILES*)
 
509
;;       (DSK-MSGS-FILE)
 
510
;;       (TAGS-OUTPUT-STREAM)
 
511
;;       (TAGS-OUTPUT-STREAM-STATE)
 
512
;;       (WINP NIL)
 
513
;;       (TRUE-IN-FILE-NAME))
 
514
;;     (UNWIND-PROTECT
 
515
;;      (PROGN
 
516
;;       (SETQ IN-FILE  (OPEN IN-FILE-NAME)
 
517
;;           TRUE-IN-FILE-NAME (TO-MACSYMA-NAMESTRING (TRUENAME IN-FILE))
 
518
;;           $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED TRUE-IN-FILE-NAME
 
519
;;           TRANSL-FILE (DELETE-OLD-AND-OPEN
 
520
;;                        (MERGEF (trlisp-outputname-temp)
 
521
;;                                OUT-FILE-NAME))
 
522
;;           DSK-MSGS-FILE (DELETE-OLD-AND-OPEN
 
523
;;                          #+cl
 
524
;;                           (merge-pathnames out-file-name
 
525
;;                                            (make-pathname :type "unlisp"))
 
526
;;                           #-cl(MERGEF (trcomments-outputname-temp)
 
527
;;                                  OUT-FILE-NAME)
 
528
;;                           )
 
529
;;           *TRANSLATION-MSGS-FILES* (LIST DSK-MSGS-FILE))
 
530
;;       (IF $TR_GEN_TAGS
 
531
;;         (SETQ TAGS-OUTPUT-STREAM
 
532
;;               (OPEN-out-dsk (MERGEF (trtags-outputname-temp)
 
533
;;                                     IN-FILE-NAME))))
 
534
;;       (IF TTYMSGSP
 
535
;;         (SETQ *TRANSLATION-MSGS-FILES*
 
536
;;               (CONS #-cl TYO #+cl *standard-output* *TRANSLATION-MSGS-FILES*)))
 
537
;;        #-cl(PROGN(CLOSE IN-FILE)
 
538
;;            ;; IN-FILE stream of no use with old-io BATCH1.
 
539
;;             (SETQ IN-FILE NIL))
 
540
;;       (MFORMAT DSK-MSGS-FILE "~%This is the `unlisp' file for ~A.~%"
 
541
;;              TRUE-IN-FILE-NAME)
 
542
;;       (MFORMAT *terminal-io* "~%Translation begun on ~A.~%"
 
543
;;              TRUE-IN-FILE-NAME)
 
544
;;       (IF TRF-START-HOOK (FUNCALL TRF-START-HOOK TRUE-IN-FILE-NAME))
 
545
;;       #-cl
 
546
;;       (IF TAGS-OUTPUT-STREAM (TAGS-START//END IN-FILE-NAME))
 
547
;;       (CALL-BATCH1 in-file transl-file)
 
548
;;       ;; BATCH1 calls TRANSLATE-MACEXPR on each expression read.
 
549
;;       (MFORMAT DSK-MSGS-FILE
 
550
;;              "~%//* Variable settings were *//~%~%")
 
551
;;       (DO ((L (CDR $TR_STATE_VARS) (CDR L)))
 
552
;;         ((NULL L))
 
553
;;       (MFORMAT-OPEN DSK-MSGS-FILE
 
554
;;                     "~:M:~:M;~%"
 
555
;;                     (CAR L) (SYMBOL-VALUE (CAR L))))
 
556
;;       #-cl(RENAME-TF OUT-FILE-NAME TRUE-IN-FILE-NAME)
 
557
;;       #-cl       (WHEN TAGS-OUTPUT-STREAM
 
558
;;           (TAGS-START//END)
 
559
;;           ;;(CLOSE TAGS-OUTPUT-STREAM) 
 
560
;;           (RENAMEF TAGS-OUTPUT-STREAM (trtags-outputname)))
 
561
;;       ;;(CLOSE DSK-MSGS-FILE)
 
562
;;       ;; The CLOSE before RENAMEF clobbers the old temp file.
 
563
;;       ;; nope. you get a FILE-ALREADY-EXISTS error. darn.
 
564
;;       (let ((tr-comment-file-name (mergef (trcomments-outputname)
 
565
;;                                 out-file-name)))
 
566
;;       #-cl (if (probe-file tr-comment-file-name)
 
567
;;                   (delete-file tr-comment-file-name))
 
568
;;      #-cl (RENAMEF DSK-MSGS-FILE tr-comment-file-name)
 
569
;;       (SETQ WINP T)
 
570
;;       #-cl`((MLIST) ,(TO-MACSYMA-NAMESTRING TRUE-IN-FILE-NAME)
 
571
;;               ,(TO-MACSYMA-NAMESTRING OUT-FILE-NAME)
 
572
;;               ,(TO-MACSYMA-NAMESTRING (TRUENAME tr-comment-file-name))
 
573
;;               ,@(IF TAGS-OUTPUT-STREAM
 
574
;;                     (LIST (TO-MACSYMA-NAMESTRING
 
575
;;                            (TRUENAME TAGS-OUTPUT-STREAM)))
 
576
;;                     NIL))
 
577
;;      #+cl `((mlist) ,(send in-file :truename)
 
578
;;              ,(send transl-file :truename)
 
579
;;              ,(send dsk-msgs-file :truename))))
 
580
;;      ;; Unwind protected. 
 
581
;;      (IF DSK-MSGS-FILE (CLOSE DSK-MSGS-FILE))
 
582
;;      (IF TRANSL-FILE   (CLOSE TRANSL-FILE))
 
583
;;      (if in-file  (close in-file))
 
584
;;      (IF TAGS-OUTPUT-STREAM (CLOSE TAGS-OUTPUT-STREAM))
 
585
;;      (WHEN (AND (NOT WINP) (NOT *TRANSL-FILE-DEBUG*))
 
586
;;          (IF TAGS-OUTPUT-STREAM (DELETE-FILE TAGS-OUTPUT-STREAM))
 
587
;;          (IF TRANSL-FILE (DELETE-FILE TRANSL-FILE)))))))
 
588
 
 
589
 
 
590
;; Should be rewritten to use streams.  Barf -- perhaps SPRINTER
 
591
;; doesn't take a stream argument?
 
592
;; Yes Carl SPRINTER is old i/o, but KMP is writing a new one for NIL. -GJC
 
593
 
 
594
(defun print* (p)
 
595
  (let ((^w t)
 
596
        (outfiles (list transl-file))
 
597
        (^r t)
 
598
                                        ;#-cl(*NOPOINT NIL)
 
599
        ($loadprint nil)) ;;; lusing old I/O !!!!!
 
600
    (declare (special outfiles))
 
601
    (sub-print* p)))
589
602
 
590
603
;;; i might as well be real pretty and flatten out PROGN's.
591
604
 
592
 
(DEFUN SUB-PRINT* (P &AUX (FLAG NIL))
593
 
  (COND ((ATOM P))
594
 
        ((AND (EQ (CAR P) 'PROGN) (CDR P) (EQUAL (CADR P) ''COMPILE))
595
 
         (MAPC #'SUB-PRINT* (CDDR P)))
596
 
        (T
597
 
         (SETQ FLAG (AND $TR_SEMICOMPILE
598
 
                         (NOT (MEMQ (CAR P) '(EVAL-WHEN INCLUDEF)))))
599
 
         (WHEN FLAG (PRINC* '|(PROGN|) (TERPRI*))
600
 
         (COND ($COMPGRIND
601
 
                (SPRIN1 P))
602
 
               (T
603
 
                (PRIN1 P TRANSL-FILE)))
604
 
         (WHEN FLAG (PRINC* '|)|))
605
 
         (TERPRI TRANSL-FILE))))
606
 
 
607
 
(DEFUN PRINC* (FORM) (PRINC FORM TRANSL-FILE))
608
 
 
609
 
(DEFUN NPRINC* (&REST FORM)
610
 
  (MAPC #'(LAMBDA (X) (PRINC X TRANSL-FILE)) FORM))
611
 
 
612
 
(DEFUN TERPRI* () (TERPRI TRANSL-FILE))
613
 
 
614
 
(DEFUN PRINT-MODULE (M)
615
 
  (NPRINC* " " M " version " (GET M 'VERSION)))
616
 
 
617
 
(DEFUN NEW-COMMENT-LINE ()
618
 
  (TERPRI*)
619
 
  (PRINC* ";;;"))
620
 
 
621
 
(defun print-TRANSL-MODULEs ()
622
 
  (NEW-COMMENT-LINE)
623
 
  (PRINT-MODULE 'TRANSL-AUTOLOAD)
624
 
  (DO ((J 0 (f1+ J))
625
 
       (S (zl-DELETE 'TRANSL-AUTOLOAD (copy-top-level TRANSL-MODULES ))
626
 
          (CDR S)))
627
 
      ((NULL S))
628
 
    (IF (= 0 (fixnum-remainder J 3)) (NEW-COMMENT-LINE))
629
 
    (PRINT-MODULE (CAR S))))
630
 
 
631
 
 
632
 
(DEFUN PRINT-TRANSL-HEADER (SOURCE)
633
 
  (MFORMAT TRANSL-FILE
 
605
(defun sub-print* (p &aux (flag nil))
 
606
  (cond ((atom p))
 
607
        ((and (eq (car p) 'progn) (cdr p) (equal (cadr p) ''compile))
 
608
         (mapc #'sub-print* (cddr p)))
 
609
        (t
 
610
         (setq flag (and $tr_semicompile
 
611
                         (not (memq (car p) '(eval-when includef)))))
 
612
         (when flag (princ* '|(PROGN|) (terpri*))
 
613
         (cond ($compgrind
 
614
                (sprin1 p))
 
615
               (t
 
616
                (prin1 p transl-file)))
 
617
         (when flag (princ* '|)|))
 
618
         (terpri transl-file))))
 
619
 
 
620
(defun princ* (form) (princ form transl-file))
 
621
 
 
622
(defun nprinc* (&rest form)
 
623
  (mapc #'(lambda (x) (princ x transl-file)) form))
 
624
 
 
625
(defun terpri* () (terpri transl-file))
 
626
 
 
627
(defun print-module (m)
 
628
  (nprinc* " " m " version " (get m 'version)))
 
629
 
 
630
(defun new-comment-line ()
 
631
  (terpri*)
 
632
  (princ* ";;;"))
 
633
 
 
634
(defun print-transl-modules ()
 
635
  (new-comment-line)
 
636
  (print-module 'transl-autoload)
 
637
  (do ((j 0 (f1+ j))
 
638
       (s (zl-delete 'transl-autoload (copy-top-level transl-modules ))
 
639
          (cdr s)))
 
640
      ((null s))
 
641
    (if (= 0 (fixnum-remainder j 3)) (new-comment-line))
 
642
    (print-module (car s))))
 
643
 
 
644
 
 
645
(defun print-transl-header (source)
 
646
  (mformat transl-file
634
647
           ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp -*-~%")
635
 
  (IF SOURCE
636
 
      (MFORMAT TRANSL-FILE ";;; Translated code for ~A" SOURCE)
637
 
      (MFORMAT TRANSL-FILE 
638
 
               ";;; Translated MACSYMA functions generated by COMPFILE."))
639
 
  (MFORMAT TRANSL-FILE
640
 
           "~%;;; Written on ~:M, from MACSYMA ~A~
 
648
  (if source
 
649
      (mformat transl-file ";;; Translated code for ~A" source)
 
650
      (mformat transl-file 
 
651
               ";;; Translated Maxima functions generated by `compfile'."))
 
652
  (mformat transl-file
 
653
           "~%;;; Written on ~:M, from Maxima ~A~
641
654
            ~%;;; Translated for ~A~%" 
642
 
           ($TIMEDATE) $VERSION (sys-user-id))
643
 
  (print-TRANSL-MODULEs)
644
 
  (MFORMAT TRANSL-FILE
 
655
           ($timedate) $version (sys-user-id))
 
656
  (print-transl-modules)
 
657
  (mformat transl-file
645
658
           ;; The INCLUDEF must be in lower case for transportation
646
659
           ;; of translated code to Multics.
647
660
           "~%~
648
661
           ~%(includef (cond ((status feature ITS) '|DSK:LIBMAX;TPRELU >|)~
649
662
           ~%                ((status feature Multics) '|translate|)~
650
663
           ~%                ((status feature Unix) '|libmax//tprelu.l|)~
651
 
           ~%                (t (MAXIMA-ERROR '|Unknown system, see GJC@MIT-MC|))))~
 
664
           ~%                (t (maxima-error '|Unknown system, see GJC@MIT-MC|))))~
652
665
           ~%~
653
 
           ~%(eval-when (compile eval)~
 
666
           ~%(eval-when (compile eval) ~
654
667
           ~%  (or (status feature lispm)~
655
668
           ~%      (setq *infile-name-key*~
656
669
           ~%               ((lambda (file-name)~
660
673
           ~%                                (t file-name)))~
661
674
           ~%                  (truename infile)))))~
662
675
           ~%~
663
 
           ~%(eval-when (compile)~
 
676
           ~%(eval-when (compile) ~
664
677
           ~%   (setq $tr_semicompile '~S)~
665
678
           ~%   (setq forms-to-compile-queue ()))~
666
679
           ~%~%(comment ~S)~%~%"
667
 
            $tr_semicompile source)
668
 
(COND ($TRANSCOMPILE
669
 
       (UPDATE-GLOBAL-DECLARES)
670
 
       (IF $COMPGRIND
671
 
           (MFORMAT
672
 
            TRANSL-FILE
673
 
            ";;; General declarations required for translated MACSYMA code.~%"))
674
 
       (PRINT* `(DECLARE . ,DECLARES))))
675
 
 
676
 
)
677
 
 
678
 
(DEFUN PRINT-ABORT-MSG (FUN FROM)
679
 
  (MFORMAT *TRANSLATION-MSGS-FILES*
 
680
           $tr_semicompile source)
 
681
  (cond ($transcompile
 
682
         (update-global-declares)
 
683
         (if $compgrind
 
684
             (mformat
 
685
              transl-file
 
686
              ";;; General declarations required for translated Maxima code.~%"))
 
687
         (print* `(declare . ,declares))))
 
688
 
 
689
  )
 
690
 
 
691
(defun print-abort-msg (fun from)
 
692
  (mformat *translation-msgs-files*
680
693
           "~:@M failed to Translate.~
681
694
            ~%~A will continue, but file output will be aborted."
682
 
           FUN FROM))
 
695
           fun from))
683
696
 
684
697
(defmacro extension-filename (x) `(caddr (namelist ,x)))
685
 
#-cl
686
 
(DEFUN RENAME-TF (NEW-NAME TRUE-IN-FILE-NAME)
687
 
  ;; copy the TRANSL-FILE to the file of the new name.
688
 
  (let ((IN-FILE))
689
 
    (UNWIND-PROTECT
690
 
     (PROGN
691
 
      (SETQ IN-FILE (OPEN-in-dsk TRANSL-FILE))
692
 
      (SETQ TRANSL-FILE
693
 
            (OPEN-out-dsk (TRUENAME NEW-NAME)))
694
 
      (PRINT-TRANSL-HEADER TRUE-IN-FILE-NAME)
695
 
      (MAPC #'PRINT* (NREVERSE *PRE-TRANSL-FORMS*))     ; clever eh?
696
 
      (terpri*)
697
 
      (PUMP-STREAM IN-FILE TRANSL-FILE)
698
 
      (MFORMAT TRANSL-FILE "~%(compile-forms-to-compile-queue)~%~%")
699
 
      (DELETEF IN-FILE))
700
 
     ;; if something lost...
701
 
     (IF IN-FILE (CLOSE IN-FILE))
702
 
     (IF TRANSL-FILE (CLOSE TRANSL-FILE)))))
703
 
 
704
 
 
705
 
(DEFUN PUMP-STREAM (IN OUT &optional (n #-cl (lsh -1 -1)
706
 
                                        #+cl  most-positive-fixnum))
707
 
  (declare (fixnum n))
708
 
  (DO ((C 0))
709
 
      ((ZEROP N))
710
 
    (DECLARE (FIXNUM C))
711
 
    (SETQ C (+TYI IN -1))
712
 
    (IF (= C -1) (RETURN NIL))
713
 
    (+TYO C OUT)
714
 
    (SETQ N (f1- N))))
 
698
 
 
699
;;#-cl
 
700
;;(DEFUN RENAME-TF (NEW-NAME TRUE-IN-FILE-NAME)
 
701
;;  ;; copy the TRANSL-FILE to the file of the new name.
 
702
;;  (let ((IN-FILE))
 
703
;;    (UNWIND-PROTECT
 
704
;;     (PROGN
 
705
;;      (SETQ IN-FILE (OPEN-in-dsk TRANSL-FILE))
 
706
;;      (SETQ TRANSL-FILE
 
707
;;          (OPEN-out-dsk (TRUENAME NEW-NAME)))
 
708
;;      (PRINT-TRANSL-HEADER TRUE-IN-FILE-NAME)
 
709
;;      (MAPC #'PRINT* (NREVERSE *PRE-TRANSL-FORMS*))   ; clever eh?
 
710
;;      (terpri*)
 
711
;;      (PUMP-STREAM IN-FILE TRANSL-FILE)
 
712
;;      (MFORMAT TRANSL-FILE "~%(compile-forms-to-compile-queue)~%~%")
 
713
;;      (DELETE-FILE IN-FILE))
 
714
;;     ;; if something lost...
 
715
;;     (IF IN-FILE (CLOSE IN-FILE))
 
716
;;     (IF TRANSL-FILE (CLOSE TRANSL-FILE)))))
 
717
 
 
718
;;#-cl
 
719
;;(DEFUN PUMP-STREAM (IN OUT &optional (n #-cl (lsh -1 -1)
 
720
;;                                      #+cl  most-positive-fixnum))
 
721
;;  (declare (fixnum n))
 
722
;;  (DO ((C 0))
 
723
;;      ((ZEROP N))
 
724
;;    (DECLARE (FIXNUM C))
 
725
;;    (SETQ C (+TYI IN -1))
 
726
;;    (IF (= C -1) (RETURN NIL))
 
727
;;    (+TYO C OUT)
 
728
;;    (SETQ N (f1- N))))
715
729
             
716
 
 
717
 
 
718
 
(DEFMSPEC $TRANSLATE (FUNCTS) (SETQ FUNCTS (CDR FUNCTS))
719
 
  (COND ((AND FUNCTS ($LISTP (CAR FUNCTS)))
720
 
         (MERROR "Use the function TRANSLATE_FILE"))
721
 
        (T
722
 
         (COND ((OR (MEMQ '$FUNCTIONS FUNCTS)
723
 
                    (MEMQ '$ALL FUNCTS))
724
 
                (SETQ FUNCTS (MAPCAR 'CAAR (CDR $FUNCTIONS)))))
725
 
         (DO ((L FUNCTS (CDR L))
726
 
              (V NIL))
727
 
             ((NULL L) `((MLIST) ,@(NREVERSE V)))
728
 
           (COND ((ATOM (CAR L))
729
 
                  (LET ((IT (TRANSLATE-FUNCTION ($VERBIFY (CAR L)))))
730
 
                    (IF IT (PUSH IT V))))
731
 
                 (T
732
 
                  (TR-TELL
733
 
                   (CAR L)
734
 
                   " is an illegal argument to TRANSLATE.")))))))
735
 
 
736
 
#+CL
737
 
(PROGN 'COMPILE
738
 
(DECLARE-TOP (SPECIAL forms-to-compile-queue))
739
 
(DEFMSPEC $COMPILE (FORM)
740
 
  (LET ((L (MEVAL `(($TRANSLATE),@(CDR FORM)))))
741
 
    (LET ((forms-to-compile-queue ()))
742
 
      (MAPC #'(LAMBDA (X) (IF (FBOUNDP X) (COMPILE X))) (CDR L))
743
 
      (DO ()
744
 
          ((NULL FORMS-TO-COMPILE-QUEUE) L)
745
 
        (MAPC #'(LAMBDA (FORM)
746
 
                  (EVAL FORM)
747
 
                  (AND (consp FORM)
748
 
                       (EQ (CAR FORM) 'DEFUN)
749
 
                       (SYMBOLP (CADR FORM))
750
 
                       (COMPILE (CADR FORM))))
751
 
              (PROG1 FORMS-TO-COMPILE-QUEUE
752
 
                     (SETQ FORMS-TO-COMPILE-QUEUE NIL)))))))
753
 
)
 
730
 
 
731
(defmspec $translate (functs) (setq functs (cdr functs))
 
732
          (cond ((and functs ($listp (car functs)))
 
733
                 (merror "Use the function `translate_file'"))
 
734
                (t
 
735
                 (cond ((or (memq '$functions functs)
 
736
                            (memq '$all functs))
 
737
                        (setq functs (mapcar 'caar (cdr $functions)))))
 
738
                 (do ((l functs (cdr l))
 
739
                      (v nil))
 
740
                     ((null l) `((mlist) ,@(nreverse v)))
 
741
                   (cond ((atom (car l))
 
742
                          (let ((it (translate-function ($verbify (car l)))))
 
743
                            (if it (push it v))))
 
744
                         (t
 
745
                          (tr-tell
 
746
                           (car l)
 
747
                           " is an illegal argument to `translate'.")))))))
 
748
 
 
749
(progn 'compile
 
750
       (declare-top (special forms-to-compile-queue))
 
751
       (defmspec $compile (form)
 
752
         (let ((l (meval `(($translate),@(cdr form)))))
 
753
           (let ((forms-to-compile-queue ()))
 
754
             (mapc #'(lambda (x) (if (fboundp x) (compile x))) (cdr l))
 
755
             (do ()
 
756
                 ((null forms-to-compile-queue) l)
 
757
               (mapc #'(lambda (form)
 
758
                         (eval form)
 
759
                         (and (consp form)
 
760
                              (eq (car form) 'defun)
 
761
                              (symbolp (cadr form))
 
762
                              (compile (cadr form))))
 
763
                     (prog1 forms-to-compile-queue
 
764
                       (setq forms-to-compile-queue nil))))))))