;; -*-  Mode: COMMON-LISP; Package: PASCALX; Base: 10; Fonts:(MEDFNT HL12B HL12I MEDFNB)-*-

3(DEFCONSTANT FILE-STREAM-OP*           (make-print-identifier :name '*file*-stream :package 'pascalx))
3(DEFCONSTANT SET-UP-FILE-VARIABLE-OP* (make-print-identifier :name '*set-up-file-variable*
								:package 'pascalx))

3(DEFVAR *INTERNAL-PASCAL-PREFIX* nil)*

(DEFVAR *gen-closure-p* nil)

(DEFVAR *closure-variables* nil)

(proclaim '(type symbol *INTERNAL-PASCAL-PREFIX*))

<(DEFUN DO-PAS (FN &REST OTHER-ARGS)*
   "2Translates Pascal FN to lisp, compiles it, and loads it.  OTHER-ARGS get passed to pascalx*"
  (apply #'pascalx fn other-args)
  (compile-file fn)
  (load fn))

;1;; The top level routine that translates
3(DEFUN PASCALX (PASCAL-FILE &key LISP-FILE (LOG *STANDARD-OUTPUT*) (GRIND T)
                                     BATCH-P **;3PARSE-ONLY-P*
					  3(OUTPUT-PACKAGE*
					       3'USER)*
					  gen-closure-p3)*
  "Translates2 *the pascal program in PASCAL-FILE to a lisp program (written to LISP-FILE).
Note that the names of procedures, variables, functions, types, constants, and the main
program in PASCAL-FILE will remain unchanged in the LISP code unless there is a name clash
between PASCAL and LISP (such as defining function CAR in the pascal) in which case a number 
will be appended to the apropriate identifier(s). Thus, in most cases, to run the translated
(LISP) file, simply compile it, loaded it, and call the function that has the name as the
pascal program (in the appropriate package; see OUTPUT-PACKAGE below).

LISP-FILE defaults to the same name as PASCAL-FILE with a .lisp extention
LOG specifies where (and whether) to write the listing produced by the front end.
    It defaults to *standard-output*, and can be set to nil (in which case no listing is made).
GRIND specifies whether to format the translated file using grindef or prin1 (t means grindef).
BATCH-P specifies whether or not to echo the LISP-FILE to the terminal (t means to echo it)
OUTPUT-PACKAGE specifies the package in which the LISP-FILE will be defined. It defaults
    to package USER. Note: the package must exist at translation time.
GEN-CLOSURE-P specifies whether or not to create `pascal closure functions.' If it is T, then
    the translator will generate three functions at the end of the LISP-FILE. The first will be
    MAKE-<name>-CLOSURE (where <name> stands for the name of the pascal program), which initializes
    and returns an array which has one slot for each program variable in the 
    pascal program. The second function, SAVE-<name>-CLOSURE saves the current `pascal environment'
    (the bindings of all the program variables) in an array (generated by MAKE-<name>-CLOSURE).
    It then returns this array. Finally, the third function DUMP-<name>-CLOSURE (which takes 1
    argument, PASCAL-CLOSURE, an array of the form generated by SAVE-<name>-CLOSURE) dumps all
    the values in PASCAL-CLOSURE into the current pascal environment, so that the next time the
    pascal program is called, all its variables will be set to the values specified in the
    PASCAL-CLOSURE." 

   ;1; validate arguments*
   (when-type-checking
     (check-type pascal-file (or symbol string pathname))
     (check-type lisp-file (or symbol string pathname))
     (check-type log (or symbol string pathname stream))
     (check-type output-package (satisfies find-package) "a package object or a package name")
     );1when-type-checking*
   
   (let* ((parse-only-p nil)
	  (DEFAULT-CONS-AREA *PASCALX-DEFAULT-AREA*)
	  (*PACKAGE*         (find-package "PASCALX"))
	  (pascal-pathname   (merge-pathnames pascal-file (make-pathname :canonical-type :pascal)))
	  (lisp-default      (make-pathname :type "LISP" :defaults pascal-pathname))
	  (lisp-pathname     (if (null lisp-file)
				 lisp-default
				 (merge-pathnames lisp-file lisp-default)))) 
     ;1; record arguments*
     (setf *OUTPUT-PACKAGE*     output-package)
     (setf *BATCH-MODE-P*       batch-p)
     (SETF *GRIND-THE-DEF* grind)
     (SETF *gen-closure-p* gen-closure-p)
     (SETF *closure-variables* nil)

     ;1; open log output stream*
     (with-open-stream (*LOG-STREAM* (typecase log
				       (stream log)
				       (null (make-broadcast-stream))
				       (otherwise (merge-pathnames log (make-pathname :type "TEXT")))))
       ;1; open the Pascal input file and parse it*
       (with-open-file (*PASCAL-STREAM* pascal-pathname :direction :input)
	 (format *LOG-STREAM* "~%Translating Pascal file:  ~A~
                             2   *~%to Lisp file:             ~A~2%"
		 (namestring pascal-pathname) (namestring lisp-pathname))
	 (init-lexi)
	 (let ((DEFAULT-CONS-AREA *PASCALX-TEMP-AREA*))
	   (setf *INTERNAL-PASCAL-PREFIX* (program)))
	 );1with-open-file*
       (format *LOG-STREAM* "~2%No syntax errors.~%")
       
       ;1; generate Lisp*
       (when (not parse-only-p)
	 (generate-code lisp-pathname nil))
       (format *LOG-STREAM* "~2%Translation complete.")
       (unless *BATCH-MODE-P*
	 (format *STANDARD-OUTPUT* "~%Translation complete.~%"))
       )				   ;1with-open-stream*
     );1let**
   (room)
   );1pascalx


3(DEFUN GENERATE-CODE (&OPTIONAL LISP-PATHNAME** 3(CODE-GEN-ONLY-P T))*
   (when code-gen-only-p
     (format *LOG-STREAM* "~2%Generating code from *INTERNAL-PASCAL-PREFIX*~2%"))
   (format *LOG-STREAM* "Formatting code, putting code in package ~A~2%" *OUTPUT-PACKAGE*)

   ;1; initialize*
   (setf *CURRENT-DEFINITION-STACK* () )
   (setf *FORWARD-DECLARED-ROUTINES-PARAMETERS* () )
   (init-symtab)

   ;1; open Lisp output file and generate code*
   (with-open-stream (*LISP-STREAM* (if *BATCH-MODE-P*
					;1; then this is a batch run, so just write to the file*
					(open lisp-pathname :direction :output
					      :if-exists :supersede
					      :if-does-not-exist :create)
					;1; else this is interactive, so echo file to screen*
					(make-broadcast-stream *STANDARD-OUTPUT*
							   (open lisp-pathname :direction :output
								               :if-exists :supersede
							                       :if-does-not-exist :create))))
     (let ((DEFAULT-CONS-AREA *PASCALX-TEMP-AREA*))
       (print-init-stuff)
       (gen-program *internal-pascal-prefix*))
     );1with-open-stream*
   );1generate-code*

;1; ++ sjp slashified make-system options and changed default font *7/03/86 12:04:01
3(DEFUN PRINT-INIT-STUFF ()*
;   (declare (function print-init-stuff () nil)
;	    (values ignore))
2   *(format *LISP-STREAM* ";;; -*- Mode: COMMON-LISP; Package: ~A; Fonts:(CPTFONT HL12B HL12I) -*-~2%"
	  *OUTPUT-PACKAGE*)
  (grind-to-lisp-stream '(eval-when (compile load)
			   (make-system 'user:pascalx-runtime :noconfirm :silent :compile)))
  );1print-init-stuff


3(DEFUN SET-UP-PROGRAM-PARM-LIST (parms prefix)**
  2"generate a program parameter-list"*
  (cons '&optional
	(mapcar #'(lambda (symtab-id id)
		1     ;; get rid of directives*
		    (loop
		      (when (eq (op-name (oper id)) '*identifier*) (return))
		      (setf id (arg1 id)))
		    ;1; ++ sjp used quote to keep *standard-in/out* from*
		1      *;1; expanding *7/08/86 13:34:32
		    (case symtab-id
		     (input    (list (make-lisp-struct-from-op symtab-id (oper id)) '*STANDARD-INPUT*))
		     (output   (list (make-lisp-struct-from-op symtab-id (oper id)) '*STANDARD-OUTPUT*))
		     (otherwise
		      ;; Must get actual package
		      (make-lisp-struct-from-op (access-form (lookup-symtab symtab-id)) (oper id)))))
		parms prefix
		);1mapcar*
	);1cons*
  );1set-up-program-parm-list


3(DEFUN GEN-FILE-VARIABLE-INITIALIZATIONS (parms prefix)**
  2"generate the initializations for the program file variables"*
  (let (parm-info file-type-info comparm-info)
    (mapcar #'(lambda (symtab-id id)
	      (setf parm-info (lookup-symtab symtab-id))
	      (setf file-type-info (lookup-symtab (var-type parm-info)))
	      (setf comparm-info   (lookup-symtab
				       (symtab-component-type file-type-info)))
	      (list (access-form parm-info)
		    (list* set-up-file-variable-op
			   (list 'quote (access-form parm-info))
			   (access-form parm-info)
			   (or (and (typep comparm-info 'primitive-type)
				    (eq (required-type comparm-info) :char))
			       (and (typep comparm-info 'symtab-subrange-type)
				    (eq (host-type comparm-info) :char)))
			   (list (init-function comparm-info))
			   *program-default-pathname*
			   (num-of-bits file-type-info)
			   (loop until (eq (op-name (oper id)) '*identifier*)
				 when (eq (op-name (oper id)) '*no-implicit-get*) collect :no-implicit-get
				 do (setf id (arg1 id))))))
	    parms prefix
	    );1mapcar*
    );1let*
  );1gen-file-variable-initializations


3(DEFUN GEN-PROGRAM (prefix &aux info** progname3)*
   2"generate the top level program"*
   (unless (eq (op-name (oper prefix)) '*program*)
     (error-handler 'program "expected *PROGRAM* as the first operator in"))
   (mark-symtab nil)
   (setf info (insert-symtab (arg1 (arg1 prefix)) :program
			     :parms (mapcar #'(lambda (id)
						1;; get rid of directives*
						(loop
						    (when (eq (op-name (oper id)) '*identifier*) (return))
						    (setf id (arg1 id)))
						(arg1 id))
					    (arg2 prefix))))
   (setq progname
	 (gen-variable-access (arg1 prefix)))
   (SETQ *program-default-pathname*
	 (INTERN (FORMAT nil "3*~a-DEFAULT-DIRECTORY**"
			 progname)
		 *output-package*))
   (grind-to-lisp-stream `(DEFVAR ,*program-default-pathname*
				  ""))
   (multiple-value-bind (blck special-vars) (gen-block (arg3

							   prefix))
     
     (IF special-vars
	 (grind-to-lisp-stream
	     `(PROCLAIM '(special . ,special-vars)))) 
     (grind-to-lisp-stream
	 (append (list (make-lisp-struct-from-op 'defun (oper
							    prefix))
		       progname
		       (set-up-program-parm-list (prog-parms info) (arg2 prefix)))
		 `((let (,@(gen-file-variable-initializations (prog-parms info) (arg2 prefix))
			 (,(make-print-identifier :name '*open-streams*
						  :package 'pascalx) nil)
			 (*stream-abort-flag* t))
;		  ,(if special-vars special-vars nil)
		     (unwind-protect (progn ,blck
					    (setf *stream-abort-flag* nil))
		       (mapc #'(lambda (str)
				 (global:close str *stream-abort-flag*))
			     ,(make-print-identifier :name '*open-streams*
						     :package 'pascalx))
		       ,@(mapcar #'(lambda (x)
				     (if (or (eq x
						 'input) (eq x 'output))
					 ;1; ++ added*
					 ;1; :abort*
					 ;1; *7/03/86 12:54:17
					 `(global:close (,file-stream-op ,x)
							*stream-abort-flag*)))
				 (prog-parms
				     info)))))))
     (when *gen-closure-p*
       (let ((no-of-vars (length *closure-variables*)))
	 (grind-to-lisp-stream
	   `(defun ,(intern (format nil "3MAKE-~A-CLOSURE*" progname)
			    *output-package*) ()
	      (let ((res 
		      (make-array ,(1+ no-of-vars) ;1 because it is named*
				  :named-structure-symbol
				  ',(INTERN
				      (FORMAT nil "3*~A-CLOSURE**"
					      progname)
				      *output-package*))))
		,@(MAPLIST
		    #'(lambda (vars)
			(LET ((info (lookup-symtab (arg1 (car vars)))))
			  `(setf
			     (aref res ,(length vars))
			     ,(get-init-form (var-type info)))))
		    *closure-variables*)
		res)))
	 (grind-to-lisp-stream
	   `(DEFUN ,(INTERN (FORMAT nil "3SAVE-~A-CLOSURE*"
				    progname)
			    *output-package*)
		   ()
	      (LET ((res (,(intern (format nil "3MAKE-~A-CLOSURE*" progname)
				   *output-package*))))
		,@(MAPLIST
		    #'(lambda (vars)
			(LET ((info (lookup-symtab (arg1 (car vars)))))
			  `(,(return-assignment-function
			       (car vars))
			    (aref res ,(length vars))
			    ,(make-lisp-struct-from-op
			       (access-form info)
			       (oper (car vars))))))
		    *closure-variables*)
		res)))
	 (grind-to-lisp-stream
	   `(DEFUN ,(INTERN (FORMAT nil "3DUMP-~A-CLOSURE*"
				    progname)
			    *output-package*)
		   (pascal-closure)
	      ,@(MAPLIST
		  #'(lambda (vars)
		      (LET ((info (lookup-symtab (arg1 (car vars)))))
			`(,(return-assignment-function
			     (car vars))
			  ,(make-lisp-struct-from-op
			     (access-form info)
			     (oper (car vars)))
			  (aref pascal-closure ,(length vars)))))
		  *closure-variables*)
	      pascal-closure))))
     )
   );1gen-program

3(DEFUN RETURN-ASSIGNMENT-FUNCTION (**var3)*
  2"return *set*, *copyarray*, etc."*
  (let (info assign-fun access lhs-type funcall?)
    (multiple-value-setq (access lhs-type funcall?)
			 (gen-variable-access var))
    ;1; funcall? should always be nil*
    (setf assign-fun
	  (assign-function
	      (setf info (lookup-symtab lhs-type))))
    (make-lisp-struct assign-fun nil nil)
    );1let*
  );1gen-assignment-statement


;;; FUN-ID is the function identifier if this is the block of a function, this is put in the PROG list
3(DEFUN GEN-BLOCK (prefix &optional (fun-id nil)**
			    &aux stmt-part fun-info syms)
  2"Calls the label, constant, type, variable, procedure and function declaration parts and* 2the statement part to generate
code for each part."*
  (enter-labels (first prefix)) (gen-label-declarations (first prefix))
  (enter-constants (second prefix)) (gen-constant-definitions (second prefix))
  (gen-type-definitions (third prefix))
  (enter-variables (fourth prefix))
  (gen-procedure-and-function-declarations (fifth prefix))
  (print-info (car *current-definition-stack*)
	      (op-line-no (oper (sixth prefix))))
  (when (not (null fun-id))
    (setf fun-info (lookup-symtab fun-id)))
  (setf stmt-part			   1; have to do statements here so that symbols are marked special*
	(gen-statement-part (sixth prefix)
			    (if (not (null fun-id))
				(cons (list (access-form fun-info)
					    (list (init-function (lookup-symtab (returns fun-info)))))
				      (gen-variable-declarations (fourth prefix)))
				(gen-variable-declarations (fourth prefix)))
			    (not (null fun-id))))
  (values stmt-part
	  (if (not (null (setf syms
			       (union *SET-OF-GLOBAL-SYMBOLS-USED*
				      (FIRST
					  *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*)))))
	      (mapcar #'(lambda (sym)
			  (access-form (lookup-symtab sym)))
		      syms) 
	      nil))
  );1gen-block


3(DEFUN GEN-PROCEDURE-AND-FUNCTION-DECLARATIONS (prefix)**
  2"generate function and procedure declarations and defintions"*
  (loop	for pre in prefix
	for proc? = (case (op-name (oper pre))
			  (*function* nil)
			  (*procedure* t)
			  (otherwise (error-handler 'gen-procedure-and-function-declarations
						    "expected *FUNCTION* or *PROCEDURE* in")))
	for info = (if proc? (enter-procedures pre) (enter-functions pre)) 
	for forward-declared? = (or (and proc? (null (arg2 pre)) (not (null (parms info))))
				    (and (not proc?) (null (arg3 pre))))
	do (mark-symtab (string (arg1 (arg1 pre))))
	(cond ((not (null forward-declared?))
	       (enter-formal-parameters (cdr (assoc (arg1 (arg1 pre)) *FORWARD-DECLARED-ROUTINES-PARAMETERS*))))
	      ((directive? (if proc? (arg3 pre) (arg4 pre)))
	       (push (cons (arg1 (arg1 pre)) (arg2 pre)) *FORWARD-DECLARED-ROUTINES-PARAMETERS*))
	      (t (enter-formal-parameters (arg2 pre))))
	(funcall (if proc? #'gen-procedure-block #'gen-function-block )
		 pre (if forward-declared?
			 (cdr (assoc (arg1 (arg1 pre)) *FORWARD-DECLARED-ROUTINES-PARAMETERS*))
			 (arg2 pre)))
	(free-symtab))
  );1gen-procedure-and-function-declarations