;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-

;;;		LastEditDate =  24:09:55  We, 05-Aug-89  -- Jesus Boti

;;; ----------------------------------------------------------------
;;; 
;;; 		(c) Copyright, 1989,
;;; 			by Mark Boggs
;;;                     and Jesus Gonzalez Boticario
;;; 			All rights reserved
;;; 
;;; ----------------------------------------------------------------

;;; RUNTIME.LSP

;;; HISTORY
; 03-Oct-89 Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
; Correccion de un error muy importante en "save-full-gra". Antes esta
; funcion no guardaba en el fichero el contenido de la variable de Dypar
; !!used-nonterms por lo que al hacer la carga de un fichero con "loadgra"
; descpues de haber cargado una gramatica compilada, se repetian las
; referencias cruzadas para todos los no-terminales anteriormente salvados.
;
; 05-Sep-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
; Inclusion al principio de la funcion "save-full-gra" de la comprobacion
; de la extension del nombre del fichero que contendra la version "runtime"
; de la gramatica, que tendra que ser ".LSP".
;
; Introduccion de la carga de los ficheros indicados por la variable 
; "nombrefichero-FILES" para cada uno de los ficheros que se esten cargando.
;
; 30-Ago-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;            Correccion de errrores:
; La inicializacion de las variables globales asociadas al nombre del fichero
; de la gramatica que se este cargando en cada momento realizada al principio
; de la funcion "save-full-gra", necesita una declaracion del tipo "proclaim"
; para evitar que de avisos el compilador. 
;
; La llamada a las macros "new-patrules", "new-pattrans", "new-recorules" y
; "new-pattrans" esta mal hecha ya que estas macros devuelven el valor de
; las variables que apuntan y no su nombre. En su lugar se ha introducido
; la llamada a la macro "symmake" para crear dichos simbolos, y para obtener
; el valor de las variables apuntadas se ha sustituido por ej. (symbol-value
; (new-patrules f)) por (new-patrules f), y asi para todas las demas.
;
;
; 29-Ago-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;            Correccion de errores de la primera
;            version de este fichero:
; Dado que no todos los ficheros tienen creadas las variables 
; nombrefichero-FILES  y nombrefichero-TESTDATA  se ha introducido al 
; principio de la funcion SAVE-FULL-GRA la comprobacion de si existen las
; mismas antes de intentar escribirlas en el fichero de la version "runtime".
;
;
; 28-Jun-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Created.
;


;;; DOCUMENTATION
;;; This file contains functions for dumping cross-referenced grammars
;;; into a disk file.  In the case of save-full-gra that file can then
;;; be compiled using the lisp compiler.

;;; The current version of save-full-gra is not smart about terminals
;;; used in more than one file.  If this occurs there can only be one
;;; saved-grammar containing the terminal in question and it must be
;;; loaded first.  Otherwise, the lwhere and where fields for that
;;; terminal will not contain the information relating to the other
;;; occurance.  This will probably be fixed in a future version.

;;; The save-gra function is meant to save only a full grammar to disk.
;;; It makes no allowance for integrating partial grammars.

(in-package "DYPAR")

;;; This function saves the grammar currently loaded into lisp into a
;;; file which can be compiled using the lisp compiler.  Grammars saved
;;; using this function only contain the essential Xref information.
(defun save-gra (filename)
  (with-open-file
      (out filename :direction :output)
      (format out "~&(in-package ~S)~&" "DYPAR")
      (format out "(proclaim '(special !!nonterms !!patrules !!pattrans
	                               !!terminals *dypar-terminal-array*
	      			       !!files-loaded))~&")
      (format out "(setq !!files-loaded '~S)~&" !!files-loaded)
      (format out "(setq !!nonterms '~S)~&" !!nonterms)
      (dolist (nt !!nonterms)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-nt :name '~S :pattern '~S :first '~S ~
				:last '~S :fwild '~S :lwild '~S :opt '~S)) ~&"
		nt
		nt
		(get-pattern nt)
		(get-first nt)
		(get-last nt)
		(get-fwild nt)
		(get-lwild nt)
		(get-opt nt))
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" nt))
      (format out "(setq !!patrules '~S)" !!patrules)
      (dolist (r !!patrules)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
		          :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S~
		          )) ~&"
		r
		r
		(get-pattern r)
		(get-action r)
		(get-first r)
		(get-last r)
		(get-fwild r)
		(get-lwild r)
		(get-opt r)
		(get-in-strat r)
		(get-ex-strat r))
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" r))
      (format out "(setq !!pattrans '~S)" !!pattrans)
      (dolist (tr !!pattrans)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
			  :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S~
		          )) ~&"
		tr
		tr
		(get-pattern tr)
		(get-action tr)
		(get-first tr)
		(get-last tr)
		(get-fwild tr)
		(get-lwild tr)
		(get-opt tr)
		(get-in-strat tr)
		(get-ex-strat tr))
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" tr))
      (format out "(setq !!terminals '~S)" !!terminals)
      (dolist (te !!terminals)
	(format out "(put-terminal-hash ~
		       '~S ~
		       (make-terminal :name '~S :where '~S :lwhere '~S)) ~&"
		te
		te
		(get-where te)
		(get-lwhere te))
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" te))
      (format out "(if (null (boundp '*dypar-terminal-array*)) ~
		       (setq *dypar-terminal-array* ~
			     (make-array 20 ~
					 :element-type 'list ~
					 :initial-element nil))) ~&")
      (dotimes (r 20 t)
	(format out "(setf (aref *dypar-terminal-array* ~S) ~
		           '~S)"
		r
		(aref *dypar-terminal-array* r)))))



;;; This function is the same as save-gra except that all of the generated
;;; cross-reference information is saved.  That is to say, that grammars
;;; saved using this function are modifiable when changes occur to 
;;; rules which are called by those in this grammar. Se ha modificado en 
;;; gran parte esta funcion debido a que no realizaba correctamente su 
;;; cometido. Para entender los cambios introducidos es aconsejable leer
;;; los comentarios de la historia que estan al principio de este fichero.
(defun save-full-gra (nombre-fichero)
  (let ((raiz))
    (if (not (search ".LSP" 
		     (setq raiz (string-upcase nombre-fichero))))
      (setq nombre-fichero (concatenate 'string raiz ".LSP"))))
  (format t "~&Almacenando la(s) gram tica(s): ~& ~A ~&en el fichero ~A " 
	  !!files-loaded nombre-fichero)
  (with-open-file
      (out nombre-fichero :direction :output)
      (format out "~&(eval-when (load) (format t ~
	      \"~~&Cargando la(s) gram tica(s):\") ~& ~
	      (print '~A))~&" !!files-loaded)
      (format out "~&(in-package ~S)~&" "DYPAR")
      (format out "(proclaim '(special !!nonterms !!patrules !!pattrans
	                               !!terminals *dypar-terminal-array*
	      			       !!files-loaded !!not-used-nts
	      			       !!not-defined  !!used-nonterms
	      			       !!multiple-nts !!recorules
	                               *elipsis-rules* *anafora-rules*))~&")
      (format out "(setq !!files-loaded (append '~S !!files-loaded))~&"
	      !!files-loaded)
      ;; se crean para cada uno de los ficheros de gramaticas cargados las 
      ;; variables que incluyen en su nombre la raiz del nombre de cada uno
      ;; de dichos ficheros. Se cargan todos los ficheros indicados en la 
      ;; variable nombrefich-FILES.
      (do* ((ficheros !!files-loaded (cdr ficheros))
	    (f (car ficheros) (car ficheros))
	    (f-carga)) 
	   ((null ficheros)
	    (and f-carga
		 (format out "(dolist (fich  '~S  t)~% ~
			(load fich))~&" 
			 (remove-duplicates 
			   (mapcar #'read-from-string f-carga)))))
	(and (boundp (symmake f "-FILES"))
	     (let ((nuevo-files (symmake f "-FILES")))
	       (format out "(proclaim '(special ~S))~&" nuevo-files)
	       (format out "(setq ~S '~S)~&" 
		       nuevo-files
		       (symbol-value nuevo-files))
	       (setq f-carga 
		     (append (symbol-value nuevo-files) f-carga))))
	(and (boundp (symmake f "-TESTDATA"))
	     (let ((nuevo-testdata (symmake f "-TESTDATA")))
	       (format out "(proclaim '(special ~S))~&" nuevo-testdata)
	       (format out "(setq ~S '~S)~&" 
		       nuevo-testdata
		       (symbol-value nuevo-testdata))))
	(format out "(proclaim '(special ~S ~S ~S ~S))~&"
		(symmake f "-RULES")(symmake f "-TRANS")
		(symmake f "-RECOVERY")(symmake f "-NONTERMS"))
	(format out "(setq ~S '~S)~&" 
		(symmake f "-RULES")
		(new-patrules f))
	(format out "(setq ~S '~S)~&" 
		(symmake f "-TRANS") 
	        (new-pattrans f))
	(format out "(setq ~S '~S)~&" 
		(symmake f "-RECOVERY")
		(new-recovers f))
	(format out "(setq ~S '~S)~&" 
		(symmake f "-NONTERMS")
		(new-nonterms f))
	(force-output out)	
	(format out "~&(eval-when (compile) (format t \"~A~~&\"))~&" 
		(read-from-string f)))
      (format
	out
	"(setq *elipsis-rules* (append '~S *elipsis-rules*))~&"
	*elipsis-rules*)
      (format
	out
	"(setq *anafora-rules* (append '~S *anafora-rules*))~&" 
	*anafora-rules*)
      (format
	out
	"(setq !!not-used-nts (append '~S !!not-used-nts))~&" !!not-used-nts)
      (format
	out
	"(setq !!used-nonterms (append '~S !!used-nonterms))~&" 
	!!used-nonterms)
      (format
	out
	"(setq !!not-defined (append '~S !!not-defined))~&" !!not-defined)
      (format
	out
	"(setq !!multiple-nts (append '~S !!multiple-nts))~&" !!multiple-nts)
      (format out 
	"(setq !!nonterms (append '~S !!nonterms))~&" !!nonterms)
      (force-output out)
      (dolist (nt !!nonterms)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-nt :name '~S :pattern '~S :first '~S ~
				:last '~S :fwild '~S :lwild '~S :opt '~S ~
				:variables '~S :terminals '~S ~
				:parents '~S))~&"
		nt
		nt
		(get-pattern nt)
		(get-first nt)
		(get-last nt)
		(get-fwild nt)
		(get-lwild nt)
		(get-opt nt)
		(get-variables nt)
		(get-terminals nt)
		(get-nt-parents nt))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" nt))
      (format out "(setsym 'rul ~S)~&"
	      (1+ (get 'rul :current)))
      (format out "(setq !!patrules (append '~S !!patrules))" !!patrules)
      (force-output out)
      (dolist (r !!patrules)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
		          :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  :variables '~S :terminals '~S))~&"
		r
		r
		(get-pattern r)
		(get-action r)
		(get-first r)
		(get-last r)
		(get-fwild r)
		(get-lwild r)
		(get-opt r)
		(get-in-strat r)
		(get-ex-strat r)
		(get-variables r)
		(get-terminals r))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" r))
      (format out "(setsym 'recover ~S)~&"
	      (1+ (get 'recover :current)))
      (format out "(setq !!recorules (append '~S !!recorules))" !!recorules)
      (force-output out)
      (dolist (r !!recorules)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
		          :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  :variables '~S :terminals '~S))~&"
		r
		r
		(get-pattern r)
		(get-action r)
		(get-first r)
		(get-last r)
		(get-fwild r)
		(get-lwild r)
		(get-opt r)
		(get-in-strat r)
		(get-ex-strat r)
		(get-variables r)
		(get-terminals r))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" r))
      (format out "(setsym 'tra ~S)~&"
	      (1+ (get 'tra :current)))
      (format out "(setq !!pattrans (append '~S !!pattrans))" !!pattrans)
      (dolist (tr !!pattrans)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
			  :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  :variables '~S :terminals '~S))~&"
		tr
		tr
		(get-pattern tr)
		(get-action tr)
		(get-first tr)
		(get-last tr)
		(get-fwild tr)
		(get-lwild tr)
		(get-opt tr)
		(get-in-strat tr)
		(get-ex-strat tr)
		(get-variables tr)
		(get-terminals tr))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" tr))
      (format out "(setq !!terminals (append '~S !!terminals))~&" !!terminals)
      (force-output out)
      ;; se ha introducido los simbolos $ y $n para que quede constancia
      ;; en el fichero de las referencias cruzadas almacenadas en los
      ;; mismos.
      (dolist (te (append '($ $n) !!terminals))
	(format out "(put-terminal-hash ~
		       '~S ~
		       (make-terminal :name '~S :where '~S :lwhere '~S ~
				      :parents '~S)) ~&"
		te
		te
		(get-where te)
		(get-lwhere te)
		(get-terminal-parents te))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" te))
      (format out "(if (null (boundp '*dypar-terminal-array*)) ~
		       (setq *dypar-terminal-array* ~
			     (make-array 20 ~
					 :element-type 'list ~
					 :initial-element nil))) ~&")
      (dotimes (r 20 t)
	(format out "(setf (aref *dypar-terminal-array* ~S) ~
		           (append '~S (aref *dypar-terminal-array* ~S)))~&"
		r
		(aref *dypar-terminal-array* r)
		r)
	(force-output out))
      (format out "~&(eval-when (load) (format t ~
	      \"~~&Finalizado\"))"))
  (format t "~&Finalizado")
  (values))


(defun salvar-gramatica (nombre-fichero)
  (let ((raiz))
    (if (not (search ".LSP" 
		     (setq raiz (string-upcase nombre-fichero))))
      (setq nombre-fichero (concatenate 'string raiz ".LSP"))))
  (format t "~&Almacenando la(s) gram tica(s): ~& ~A ~&en el fichero ~A " 
	  !!files-loaded nombre-fichero)
  (with-open-file
      (out nombre-fichero :direction :output)
      (format out "~&(eval-when (load) (format t ~
	      \"~~&Cargando la(s) gram tica(s):\") ~& ~
	      (print '~A))~&" !!files-loaded)
      (format out "~&(in-package ~S)~&" "DYPAR")
      (format out "(proclaim '(special !!nonterms !!patrules !!pattrans
	                               !!terminals *dypar-terminal-array*
	      			       !!files-loaded !!recorules
	                               *elipsis-rules* *anafora-rules*))~&")
      (format out "(setq !!files-loaded (append '~S !!files-loaded))~&"
	      !!files-loaded)
      ;; se crean para cada uno de los ficheros de gramaticas cargados las 
      ;; variables que incluyen en su nombre la raiz del nombre de cada uno
      ;; de dichos ficheros. Se cargan todos los ficheros indicados en la 
      ;; variable nombrefich-FILES.
      (do* ((ficheros !!files-loaded (cdr ficheros))
	    (f (car ficheros) (car ficheros))
	    (f-carga)) 
	   ((null ficheros)
	    (and f-carga
		 (format out "(dolist (fich  '~S  t)~% ~
			(load fich))~&" 
			 (remove-duplicates 
			   (mapcar #'read-from-string f-carga)))))
	(and (boundp (symmake f "-FILES"))
	     (let ((nuevo-files (symmake f "-FILES")))
	       (format out "(proclaim '(special ~S))~&" nuevo-files)
	       (format out "(setq ~S '~S)~&" 
		       nuevo-files
		       (symbol-value nuevo-files))
	       (setq f-carga 
		     (append (symbol-value nuevo-files) f-carga))))
	(force-output out)	
	(format out "~&(eval-when (compile) (format t \"~A~~&\"))~&" 
		(read-from-string f)))
      (format
	out
	"(setq *elipsis-rules* (append '~S *elipsis-rules*))~&"
	*elipsis-rules*)
      (format
	out
	"(setq *anafora-rules* (append '~S *anafora-rules*))~&" 
	*anafora-rules*)
      (format out 
	"(setq !!nonterms (append '~S !!nonterms))~&" !!nonterms)
      (force-output out)
      (dolist (nt !!nonterms)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-nt :name '~S :pattern '~S :first '~S ~
				:last '~S :fwild '~S :lwild '~S :opt '~S ~
				))~&"
		nt
		nt
		(get-pattern nt)
		(get-first nt)
		(get-last nt)
		(get-fwild nt)
		(get-lwild nt)
		(get-opt nt))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" nt))
      (format out "(setsym 'rul ~S)~&"
	      (1+ (get 'rul :current)))
      (format out "(setq !!patrules (append '~S !!patrules))" !!patrules)
      (force-output out)
      (dolist (r !!patrules)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
		          :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  ))~&"
		r
		r
		(get-pattern r)
		(get-action r)
		(get-first r)
		(get-last r)
		(get-fwild r)
		(get-lwild r)
		(get-opt r)
		(get-in-strat r)
		(get-ex-strat r))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" r))
      (format out "(setsym 'recover ~S)~&"
	      (1+ (get 'recover :current)))
      (format out "(setq !!recorules (append '~S !!recorules))" !!recorules)
      (force-output out)
      (dolist (r !!recorules)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
		          :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  ))~&"
		r
		r
		(get-pattern r)
		(get-action r)
		(get-first r)
		(get-last r)
		(get-fwild r)
		(get-lwild r)
		(get-opt r)
		(get-in-strat r)
		(get-ex-strat r))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" r))
      (format out "(setsym 'tra ~S)~&"
	      (1+ (get 'tra :current)))
      (format out "(setq !!pattrans (append '~S !!pattrans))" !!pattrans)
      (dolist (tr !!pattrans)
	(format out "(put-rule-hash ~
		       '~S ~
		       (make-tl-rule
		          :name '~S :pattern '~S :action '~S :first '~S ~
			  :last '~S :fwild '~S :lwild '~S :opt '~S ~
		          :internal-strategy '~S :external-strategy '~S ~
			  ))~&"
		tr
		tr
		(get-pattern tr)
		(get-action tr)
		(get-first tr)
		(get-last tr)
		(get-fwild tr)
		(get-lwild tr)
		(get-opt tr)
		(get-in-strat tr)
		(get-ex-strat tr))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" tr))
      (format out "(setq !!terminals (append '~S !!terminals))~&" !!terminals)
      (force-output out)
      ;; se ha introducido los simbolos $ y $n para que quede constancia
      ;; en el fichero de las referencias cruzadas almacenadas en los
      ;; mismos.
      (dolist (te (append '($ $n) !!terminals))
	(format out "(put-terminal-hash ~
		       '~S ~
		       (make-terminal :name '~S :where '~S :lwhere '~S ~
				      )) ~&"
		te
		te
		(get-where te)
		(get-lwhere te))
	(force-output out)
	(format out "~&(eval-when (compile) (format t \"~S~~&\"))~&" te))
      (format out "(if (null (boundp '*dypar-terminal-array*)) ~
		       (setq *dypar-terminal-array* ~
			     (make-array 20 ~
					 :element-type 'list ~
					 :initial-element nil))) ~&")
      (dotimes (r 20 t)
	(format out "(setf (aref *dypar-terminal-array* ~S) ~
		           (append '~S (aref *dypar-terminal-array* ~S)))~&"
		r
		(aref *dypar-terminal-array* r)
		r)
	(force-output out))
      (format out "~&(eval-when (load) (format t ~
	      \"~~&Finalizado\"))"))
  (format t "~&Finalizado")
  (values))

(defvar *runtime-loaded* t)