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

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

;;; ----------------------------------------------------------------
;;; 
;;; 		(c) Copyright, 1983, 1984, 1989
;;; 			by Mark Boggs
;;; 		        and Jesus Gonzalez Boticario
;;;                     para Rank Xerox, Espa¤a
;;; 			All rights reserved
;;; 
;;; ----------------------------------------------------------------

;;; FILE xpar.l

;;; HISTORY
; 06-Oct-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Creacion de una nueva variable llamada !nombres-var que contendra
;      el nombre de todas las distintas variables que se hayan equiparado
;      durante el proceso de equiparacion de la regla de alto nivel que
;      se haya podido aplicar en cada momento.
;
; 05-Oct-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Creacion dos nuevas variable llamada !fecha-flag-bien y 
;      !fecha-flag-mal que inicialmente tendran un valor T, indicando
;      que la primera vez que se vaya a escribir  en algunos de los 
;      ficheros *.dat se guarde tambien la fecha y hora del dia en cuestion.
;       Se crea por este motivo la funcion "escribe-fecha".
;
; 25-Sep-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Correccion de un error en la funcion "ask-which-one" para
;      que no se pregunte al usuario por el numero de la regla
;      sino por el nombre de dicha regla. Ademas se comprueba que
;      la indicada por el usuario esta entre las que se han mostrado.
;
; 14-Sep-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Correccion de un error en la funcion "clearvar" ya que no se 
;       inicializaba el valor de la propiedad ":current" del simbolo 
;       "var" utilizado para generar los nombres de las variables 
;       de *var*.
;
; 11-Sep-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Cambio total de la funcion "applyrecos" para que no solo aplique
;       la primera regla de recuperacion que encuentre aplicable, sino
;       que ademas busque entre todas las posibles por si hay algun tipo
;       de colisiones.
;       Modificacion de la funcion "applyrecos" para que realize la 
;       asignacion de variables antes de sacar el mensaje del usuario,
;       por si este necesita mostrar el valor de dichas variables en
;       el mensaje. Tambien se han incluido los mensajes activos cuando
;       la variable !ptrace tiene valor t.
;
; 08-Sep-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Modificacion de la funcion "applyrule1" para que si el resultado
;       de evaluar la accion de una regla es NIL la funcion devuelva T,
;       para que sea interpretado correctamente por la funcion "applyrule",
;       que llama a la anterior.
;
; 28-Aug-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Modificacion de la funcion "applyrule" para incluir la 
;       aplicacion de las reglas que se encargan de avisar de errores
;       en la introduccion de datos por parte del usuario (applyrecos). 
;       Reglas contenidas en la variable !!recorules y en la variable del 
;       fichero de la gramatica cargada "nombre-fichero-recovering".
;
; 23-Aug-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Introduccion en la funcion "applyrule1" de la llamada a la 
;       funcion "elip-anaf" que realiza la integracion de la regla 
;       seleccionada, con aquellas que se deriven de la utilizacion de la
;       elipsis y anafora contenida en el fichero ELIPSIS.LSP
;
; 22-Aug-89  Jesus Gonzalez Boticario para Rank Xerox, Espa¤a
;       Se ha a¤adido en la funcion "applyrule" la integracion de la 
;       correccion ortografica (contenida en le fichero ORTO.LSP),
;       una vez se han intentado aplicar las reglas de alto nivel 
;       y las de transformacion.
;
; 09-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added Jesus' change to bindrole
;	Made clearvar reset !!current-vars to nil
;
; 08-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added unwind-protect to parser to insure that files containing
;	parse results are written out.
;
; 04-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added !success-flag and !success-file to allow retention of
;	successful parses.
;
; 08-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Fixed clearvar behaviour.
;	Integrated multi-language messages from babel.lsp
;
; 29-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted from msg to format usage.
;	Extracted format messages to babel.lsp
;	Changed dv to defvar
;	Added test for empty string inputs so as to stop the no parse message.
;
; 28-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted from property lists to structures
;
; 14-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted to GCL3.1 Beta
;	memq -> memb
;	last -> mlast
;	putprop -> ptprop
;	#+ usage eliminated and all Franz dependent calls removed
;	removed call to readlinesyn (now readline)
; 

(in-package "DYPAR"); :use '("LISP" "USER"))

;;; make sure the macros are around at compile time.
(eval-when (compile)
    (if (not (boundp '*macros-loaded*)) (load "macros"))
    (if (not (boundp '*struc-loaded*)) (load "struc"))
    (if (not (boundp '*babel-loaded*)) (load "babel"))
    )


;;; These are the global variables referenced in this file
;;; se ha incluido la variable *interfaz* para el caso en que haya 
;;; que redirigir los mensajes a streams diferentes.

(proclaim '(special !!transmax !xmatch !newvars !!pattrans
	     !!current-vars !!readlist !!patrules $%FAILURES%$
	     !failure-flag !thisrule! !!bpunct !trans !ptrace
	     !!global-strategy-int !!global-strategy-ext
	     !!raw-input *language* !failure-file *interfaz*
	     $%SUCCESSES%$ !success-flag !success-file !fecha-flag-bien
	     !fecha-flag-mal !nombres-var))

(defvar $%FAILURES%$ nil)
(defvar !fecha-flag-bien t)
(defvar !fecha-flag-mal t)
(defvar !nombres-var nil)
(defvar !failure-flag nil)
(defvar !failure-file "failed.dat")
(defvar $%SUCCESSES%$ nil)
(defvar !success-flag nil)
(defvar !success-file "success.dat")
(defvar !!transmax 4)
(defvar !!current-vars nil)
(defvar !xmatch nil)
(defvar !newvars nil)
(defvar !!global-strategy-int nil)
(defvar !!global-strategy-ext nil)

;;; *** L O W   L E V E L   S T U F F ***

;;; CLEARVAR resets the values of variables to nil so that the pattern matcher
;;; doesn't keep spitting out old information.
;;; Se ha a¤adido la inicializacion de la propiedad en base a la cual se crean
;;; los nombres de las variables generados por *var*.
(defun clearvar ()
  (dolist (var !!current-vars t)
    (setf (symbol-value var) nil))
  (setq !nombres-var nil)
  (initsym 'var)
  (setq !!current-vars nil))

(defun arg$ (l)
  (declare (list l))
  (mapc (funl (a)
	  (or (consp a)
	      (eval$ a)
	      (null a)
	      (setf (symbol-value a) nil)))
	(cdr l)))

;;; BINDROLE takes a bindings list as its argument, and for each sublist sets
;;; the car of that list to have the value of the cdr of that list.  It also
;;; maintains the !!current-vars list so that the variables can be erased.
;;; One important thing to note is that the value of the variable will always
;;; be a list.
;;; Esta funcion se ha modificado para que cada variable tenga todas las 
;;; asociaciones encontradas en una lista donde el primer elemento de
;;; dicha lista contiene el ultimo valor asignado.
(defun bindrole (l)
  (and (consp l)
       (mapc
	 (funl (v)
	       (and (consp v)
		    (litatom (car v))
		    (setcons (car v) !!current-vars)
		    (set (car v) 
			 (if (boundp (car v))
			     (or (and (eql (length v) 2)
				      (cons (cadr v) (eval (car v))))
				 (append (cdr v) (eval (car v))))
			   (cdr v)))
		    ))
	  l)))

(defun printrule (r)
  (smformat 'printrule1 (car r))
  (smformat 'printrule2 (get-action (car r)))
  (mapc (funl (r1) (format t "	~S~&" r1))
	(cdr r))
  (terpri))

;;; Unfinished function for displaying bindings -- also needs babel entry.
(defun printbindings (r)
  (format t "Match bindings are: ~&")
  (mapc (funl (r1) (format t "	~S~&" r1))
	(cdr r))
  (terpri))

;;; *** R U L E  L O O K U P ***

;;; FIND-APPLICABLE-FIRST uses the cross referencer information to locate
;;; the rules that the current first word is active in.

(defun find-applicable-first (word)
  (or (and (numberp word)
	   (get-where '$n))
      (get-where word)
      (get-where '$)))

;;; FIND-APPLICABLE-LAST does the same thing for the last word in the current
;;; input.

(defun find-applicable-last (word)
  (or (and (numberp word)
	   (get-lwhere '$n))
      (get-lwhere word)
      (get-lwhere '$)))

;;; FIND-APPLICABLE-SPECIFIC finds the most specific of the rules which might
;;; match the current input using the information returned from 
;;; FIND-APPLICABLE-FIRST and FIND-APPLICABLE-LAST.

(defun find-applicable-specific (wordf wordl)
  (intersection
    (find-applicable-first wordf)
    (find-applicable-last wordl)))

;;; FIND-APPLICABLE-GENERAL picks any rules that might fire given the current
;;; input, especially those that contain wildcards.  It does not repeat the
;;; match of rules that have already failed to fire.

(defun find-applicable-general (wordf wordl excluding)
  (mapcan (funl (rul)
		(and (not (memb rul excluding))
		     (list rul)))
	  (intersection
	    (union (get-where '$)
		   (or (and (numberp wordf)
			    (get-where '$n))
		       (get-where wordf)))
	    (union (get-lwhere '$)
		   (or (and (numberp wordl)
			    (get-lwhere '$n))
		       (get-lwhere wordl))))))


;;; *** T O P - L E V E L   R U L E   M A T C H I N G ***

;;; APPLYRULE-TRY-THEM calls the pattern matcher once for each of the rules it
;;; is given, returning the list of the results of the match with the rule
;;; name(s) of the rules that successfully matched.  As a side
;;; effect the variable `!thisrule!' is set to be the current rule each
;;; time through the loop.  This is for the use of future error correction
;;; routines within the pattern matcher.

(defun applyrule-try-them (sen rules)
  (mapcon
    (funl (r)
	  (let ((ans (xmatch sen (get-pattern (car r)))))
	    (setq !thisrule! r)		       
	    (and ans (list (cons (car r) ans)))))
    rules))

;;; APPLY-TOP-LEVEL-RULES calls APPLY-RULE-TRY-THEM first with the more
;;; specific rules, and if that fails the general ones.  It returns the
;;; the results of APPLY-RULE-TRY-THEM with no modifacation.

(defun apply-top-level-rules (sen)
  (let ((likely-rules (find-applicable-specific
			(car sen) (car (last sen)))))
    (and likely-rules (smptrace 'apply-top-level-rules1 likely-rules))
    (or (applyrule-try-them sen likely-rules)
	(and (setq likely-rules (find-applicable-general
				  (car sen)
				  (car (last sen))
				  likely-rules))
	     (progn (smptrace 'apply-top-level-rules2)
		    (smptrace 'apply-top-level-rules3 likely-rules)
		    (applyrule-try-them sen likely-rules))))))


;;; *** T R A N S F O R M A T I O N   R U L E   M A T C H I N G ***

;;; APPLYTRANS tries to match against the transformation rules, altering the
;;; users input when it succeeds.

(defun applytrans (sen trans)
  (mapc (funl (tr)
	      (let ((bindings (xmatch sen (get-pattern tr))))
		(cond (bindings
			(bindrole (cdar bindings))
			(setq !trans (1- !trans))
			(smptrace 'applytrans1 sen)
			(arg$ (get-action tr))
			(setq sen (eval (get-action tr)))
			(smptrace 'applytrans2 sen)))))
	trans)
  (clearvar)
  sen)

;;; *** M A T C H   C O L L I S I O N   R E S O L U T I O N ***

(defun max-len (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst))))
	((null l) ans)
	(cond ((> (length (car l)) (length (car ans)))
	       (setq ans (list (car l))))
	      ((= (length (car l)) (length (car ans)))
	       (setq ans (cons (car l) ans)))
	      (t nil))))

(defun least-len (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst))))
	((null l) ans)
	(cond ((< (length (car l)) (length (car ans)))
	       (setq ans (list (car l))))
	      ((= (length (car l)) (length (car ans)))
	       (setq ans (cons (car l) ans)))
	      (t nil))))

(defun count-non-nil-vars (blst)
    (do ((l (cond ((atom (car blst))
		   (cdr blst))
		  (t blst))
	    (cdr l))
	 (n 0))
	((null l) n)
	(cond ((cadr (car l))
	       (setq n (1+ n)))
	      (t nil))))

(defun max-non-nil (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst)))
	 (n (count-non-nil-vars (car lst))))
	((null l) ans)
	(let ((x (count-non-nil-vars (car l))))
	     (cond ((> x n)
		    (setq ans (list (car l)))
		    (setq n x))
		   ((= x n)
		    (setq ans (cons (car l) ans)))
		   (t nil)))))

(defun least-non-nil (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst)))
	 (n (count-non-nil-vars (car lst))))
	((null l) ans)
	(let ((x (count-non-nil-vars (car l))))
	     (cond ((< x n)
		    (setq ans (list (car l)))
		    (setq n x))
		   ((= x n)
		    (setq ans (cons (car l) ans)))
		   (t nil)))))

(defun count-input-consumed (blst)
    (do ((l (cond ((atom (car blst))
		   (cdr blst))
		  (t blst))
	    (cdr l))
	 (n 0))
	((null l) n)
	(cond ((cadr (car l))
	       (setq n (+ n (length (cdar l)))))
	      (t nil))))

(defun max-assigned (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst)))
	 (n (count-input-consumed (car lst))))
	((null l) ans)
	(let ((x (count-input-consumed (car l))))
	     (cond ((> x n)
		    (setq ans (list (car l)))
		    (setq n x))
		   ((= x n)
		    (setq ans (cons (car l) ans)))
		   (t nil)))))

(defun least-assigned (lst)
    (do ((l (cdr lst) (cdr l))
	 (ans (list (car lst)))
	 (n (count-input-consumed (car lst))))
	((null l) ans)
	(let ((x (count-input-consumed (car l))))
	     (cond ((< x n)
		    (setq ans (list (car l)))
		    (setq n x))
		   ((= x n)
		    (setq ans (cons (car l) ans)))
		   (t nil)))))

(defun ask-which-one (lst)
  (let ((rule))
    (and *interfaz* (pinta-pant-correc-orto))
    (smformat 'ask-which-one1)
    (mapc (function printrule) lst)
    (smformat 'ask-which-one2)
    ;; para comprobar que la regla esta dentro de las que se muestran
    (setq rule (do ((regla (read) (read)))
		   ((member regla lst :key #'car) regla)
		 (smformat 'confir-ask-which-one2)
		 (smformat 'ask-which-one2)))
    ;(cond ((numberp rule)
    ;	   (setq rule (concat 'rul rule))))
    (and *interfaz* (restaurar-resp-grande))
    (list (assoc rule lst))))

;;; Unfinished internal method.  -- babel entry.
(defun ask-which-one-internal (lst)
    (let ((match))
	 (format t "Multiple Match. Choose the variable grouping you want.~&")
	 (mapc (function printbindings) lst)
	 (format t "Match Selection: ")
	 (setq match (read))
	 (cond ((numberp match)
		(nth (1- match) lst)))))

(defun resolve-internal-collision (bindings-list)
  (cond ((cddr bindings-list)
	 (let ((user-fun (get-in-strat (car bindings-list)))
	       (normal-strategy '(most-vars most-non-nil most-input
					    arbitrary error)))
	   (do ((varsets (mapcar (function cdr) (cdr bindings-list)))
		(operators
		  (cond (user-fun
			  (cond ((cddr user-fun)
				 (append user-fun '(error)))
				(t (append user-fun
					   (or !!global-strategy-int
					       normal-strategy)))))
			(!!global-strategy-int
			  (append !!global-strategy-int '(error)))
			(t normal-strategy))
		  (cdr operators)))
	       ((null (cdr varsets))
		(cons (car bindings-list) (car varsets)))
	     (case (car operators)
	       (most-vars (setq varsets (max-len varsets)))
	       (most-non-nil (setq varsets (max-non-nil varsets)))
	       (most-input (setq varsets (max-assigned varsets)))
	       (arbitrary (setq varsets (list (car varsets))))
	       (error (setq varsets (list (car varsets)))
		      (smformat 'resolve-internal-collision1))
	       (t (cond ((getd (car operators))
			 (setq varsets
			       (funcall (car operators) varsets)))
			(t (smformat
			     'resolve-internal-collision2
			     (car operators))
			   (setq operators
				 (append operators '(error))))))))))
	(t (cons (car bindings-list) (cdadr bindings-list)))))

(defun make-operators (user-fun normal-strategy)
  (cond ((not (equal user-fun '(fake-out-map-hack)))
	 (cond ((cddr user-fun)
		(append user-fun '(error)))
	       (t (append user-fun
			  (or !!global-strategy-int
			      normal-strategy)))))
	(!!global-strategy-int
	  (append !!global-strategy-int '(error)))
	(t normal-strategy)))



;;; resolve-collision controls the way a multiple parse is resolved.
(defun resolve-collision (match-results)

  ;; First we resolve any internal collisions
  (let ((mr (mapcar (function resolve-internal-collision) match-results))
	(ans))
    (cond

      ;; If we still have multiple matches we need to choose a
      ;; correct match.
      ((cdr mr)
       (let ((normal-strategy '(most-vars most-non-nil most-input ask))

	     ;; If the user has specified a match resolution strategy
	     ;; for any of the colliding rules we retrieve that
	     ;; strategy and merge it into a list of all the resolution
	     ;; functions named in the colliding rules.
	     (user-fun
	       (condense
		 (mapcan
		   (funl (e)
			 (and (get-ex-strat e)
			      (list (get-ex-strat e))))
		   (mapcar (function car) mr)))))
	 (setq
	   ans
	   (condense
	     (mapcar
	       (funl
		 (s)
		 (do ((varsets mr)
		      (operators
			(make-operators
			  s
			  normal-strategy)
			(cdr operators)))
		     ((null (cdr varsets))
		      (car varsets))
		   (case (car operators)
		     (most-vars (setq varsets
				      (max-len varsets)))
		     (most-non-nil
		       (setq varsets
			     (max-non-nil varsets)))
		     (most-input
		       (setq varsets
			     (max-assigned varsets)))
		     (ask (setq varsets
				(ask-which-one varsets)))
		     (error
		       (smformat 'resolve-collision1)
		       (setq varsets
			     (ask-which-one varsets)))
		     (t (cond
			  ((getd (car operators))
			   (setq varsets
				 (funcall
				   (car operators)
				   varsets)))
			  (t (smformat 'resolve-collision2
				       (car operators))
			     (setq operators
				   (append
				     operators
				     '(error)))))))))
	       (or user-fun '((fake-out-map-hack)))))))
       (cond ((> (length ans) 1)
	      (car (ask-which-one ans)))
	     (t (car ans))))
      (t (car mr)))))


;;; Funcion encargada de devolver el nombre de las variables que hayan
;;; sido equiparadas durante el analisis de la regla que se ha equiparado
;;; con la frase de entrada.
(defun nombres-variables (list-var-gramat list-var-dypar)
  (if list-var-dypar
      (cons '!newvars (set-diff (remove-duplicates list-var-gramat)
				list-var-dypar))
    (remove-duplicates list-var-gramat)))

;;; *** H I G H   L E V E L   F U N C T I O N S ***

;;; APPLYRULE is the rule driver.  It takes a user input sentence as its
;;; single argument, and cycles through the applicable top-level rules
;;; and transformation, until some top-level rule successfully fires, or
;;; the transformations have been tried !!transmax times. Esta funcion
;;; incluye ahora la integracion de los modulos de elipsis y de anafora,
;;; tambien se han corregido algunos errores que habia en la inicializacion
;;; de variables. Igualmente se ha introducido una nueva variable en Dypar
;;; llamada !nombres-var.
(defun applyrule1 (sen)
  (if (not (string= !!raw-input ""))
      (progn
	(setq !trans !!transmax)
	(clearvar)
	(do ((ans (apply-top-level-rules sen)
		  (apply-top-level-rules sen))
	     (otrans !trans !trans)
	     (choice) (action))
	    (ans (setq !xmatch ans)
		 (setq choice (elip-anaf (resolve-collision ans)))
		 (smptrace 'applyrule1)
		 (and !ptrace (printrule choice))
		 (setq action (get-action (car choice)))
		 (bindrole (cdr choice))
		 (setq !newvars (newvars (cdr choice)))
		 (and !!current-vars
		      (setq !nombres-var (nombres-variables !!current-vars
						       !newvars)))
		 (setcons sen $%SUCCESSES%$)
		 (arg$ action)
		 (or (eval action) t))
	  (cond ((> 1 !trans) 		;si se han aplicado reglas de
		 (return nil))) 	;transformacion !!transmax veces.
	  (setq !newvars nil !!current-vars nil)
	  (setq sen (applytrans sen !!pattrans))
	  (cond ((= otrans !trans) 	;si no se ha podido aplicar 
		 (return nil))))))) 	;ninguna regla de transformacion.


;;; La siguiente funcion se utiliza para aplicar las reglas incluidas en la 
;;; variable !!recorules. Estas reglas solo contienen un mensaje en su parte
;;; de accion. Introduccion de la asignacion de variables para que tengan
;;; un valor que pueda mostrarse en un mensaje para el usuario.
;(defun applyrecos-vieja (sen)
;  (dolist (rr !!recorules nil)
;    (let ((bindings (xmatch sen (get-pattern rr))))
;      (if bindings
;	  (progn
;	    (apply (function format) (cons  t (get-action rr)))
;	    (return t))))))


;;; Nueva definicion de "applyrecos" para que realize la asignacion de
;;; variables y para que resuelva las colisiones externas e internas
;;; en el caso de que estas existan.
(defun applyrecos (sen)
  (let ((eleccion)
	(resul (applyrule-try-them sen !!recorules)))
    (if resul
	(progn
	  (setq eleccion (resolve-collision resul))
	  (smptrace 'applyrule1)
	  (and !ptrace (printrule eleccion))
	  (bindrole (cdr eleccion))
	  (setq !newvars (newvars (cdr eleccion)))
	  (eval (cons 'format (cons t  (get-action (car eleccion)))))
	  (setcons sen $%FAILURES%$)
	  t))))

;;; funcion introducida para permitir la inclusion de la correccion de
;;; errores ortograficos aplicando la funcion "revisarfrase" del fichero
;;; ORTOGRAF.LSP.
(defun applyrule (sen)
  (or (applyrule1 sen)
      (let ((rev (revisarfrase sen)))
	(and (not (equal sen rev)) (applyrule1 rev)))
      (applyrecos sen)
      ;; Las dos sentencias del "progn" estaban en la ultima sentencia "cond"
      ;; de la funcion "applyrule1" (anteriormente "applyrule"), antes de 
      ;; "(return nil)" 
      (progn (setcons sen $%FAILURES%$) ;las dos sentencias incluidas en
	     (smformat 'applyrule2 (cnvt-read-print)) ;el progn estaban
	     ))
  )

		 
(defun readline-syn ()
  (let ((input (readline)))
    (do ((inp input (cdr inp)))
	((null inp) input)
      (if (get (car inp) :synonym)
	  (rplaca inp (get (car inp) :synonym))))))

;;; PARSER is the top level loop of DYPAR.
(defun parser-old ()
    (prog (rd)
      (smformat 'parser1)
      (smformat 'parser2)
   lp (terpri)
      (prompt 43)				 ; 43 is ascii for "+"
      (setq rd (readline))
      (setq rd (filter rd !!bpunct))
      (cond ((string= !!raw-input "") (go lp))
	    ((eql 'exit (applyrule rd))
	     (and $%FAILURES%$ !failure-flag
		  (write-out-message 'failed 'faicon)
		  (setq $%FAILURES%$ nil))
	     (smformat 'parser3)
	     (smformat 'parser4)
	     (return t))
	    (t (go lp)))))

(defun write-out-message (what where)
  (declare (ignore what where))
  nil)

(defun parser ()
  (smformat 'parser1)
  (smformat 'parser2)
  (terpri)
  (prompt 43)
  (unwind-protect
      (do ((rd (filter (readline) !!bpunct)
	       (filter (readline) !!bpunct)))
	  
	  ((eql 'exit (applyrule rd))
	   (and $%FAILURES%$ !failure-flag
		(store-failures)
		(setq $%FAILURES%$ nil))
	   (and $%SUCCESSES%$ !success-flag
		(store-successes)
		(setq $%SUCCESSES%$ nil))
	   (smformat 'parser3)
	   (smformat 'parser4))
	
	(terpri)
;	(princ !!input-buffer) (terpri)
	(prompt 43))
    
;    (format t "No lo deberia poner nunca,no?")
    
    (progn (and $%FAILURES%$ !failure-flag
		(store-failures)
		(setq $%FAILURES%$ nil))
	   (and $%SUCCESSES%$ !success-flag
		(store-successes)
		(setq $%SUCCESSES%$ nil)))))

;;; Funcion para devolver al stream seleccionado la fecha y la hora actual
;;; en formato espa¤ol es decir: dia/mes/a¤o.
(defun escribe-fecha (&optional (stream *standard-output*))
  (multiple-value-bind (seg min hor dia mes ano)
      (get-decoded-time)
    (format stream "~& ***** Fecha: ~A/~A/~A  ~A:~A:~A *****" 
	    dia mes ano hor min seg)))

(defun store-failures ()
  (with-open-file (out !failure-file :direction :output
		       :if-exists :append :if-does-not-exist :create)
    (and !fecha-flag-mal
	 (progn (escribe-fecha out) (setq !fecha-flag-mal nil)))
    (dolist (f (nreverse $%FAILURES%$) t)
      (format out "~&~S" f))))

(defun store-successes ()
  (with-open-file (out !success-file :direction :output
		       :if-exists :append :if-does-not-exist :create)
    (and !fecha-flag-bien
	 (progn (escribe-fecha out) (setq !fecha-flag-bien nil)))
    (dolist (f (nreverse $%SUCCESSES%$) t)
      (format out "~&~S" f))))

(defun access (vars)
  (do ((nv vars (cdr nv))
       (ans nil (append ans (eval (car nv)))))
      ((null nv) (reverse ans))))

(defun mapfirst (fn l)     
  (do ((l l (cdr l))
       (ans))
      ((null l) nil)
    (setq ans (apply fn (list (car l))))
    (and ans (return ans))))

(defvar *xpar-loaded* t)