
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/automata.scm ...                           */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 29 08:46:33 1991                          */
;*    Last change :  Fri May  3 10:13:07 1991  (serrano)               */
;*                                                                     */
;*    Le codage des automates ...                                      */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     run-state ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Il ne faut pas oublier qu'il existe deux char speciaux *eob-char* */
;*   et *eof-char*. Ces deux chars declenchent des les lambdas         */
;*   speciales (vector-ref *eof-char*) et (vector-ref *eob-char*).     */
;*   Autrement dit, on n'a pas besoin de tester a l'execution si on    */
;*   tombre sur eob ou eof.                                            */
;*---------------------------------------------------------------------*/
(define-macro (run-state state-num indice)
   `(begin
;*        (print "run-state: " ,state-num   */
;* 	      "  indice: " ,indice   */
;* 	      "  lettre: " (string-ref buffer ,indice)   */
;*               "  ascii : " (char->ascii (string-ref buffer ,indice)) )  */
       ((vector-ref (vector-ref t-state ,state-num) 
		    (char->ascii (string-ref buffer ,indice)))
	,indice) ) )

;*---------------------------------------------------------------------*/
;*     define-automata ...                                             */
;*---------------------------------------------------------------------*/
(define (define-automata nb-states accept-0? action* the-error trap transitions*)
;*---- eof-transition -------------------------------------------------*/
   (define (eof-transition state-num)
      `(lambda (indice)
	  (if (= (1+ (stream/rp-backward stream)) (stream/rp-forward stream))
	      ;;; il n'y a plus rien a matcher
	      (begin
		 (set! matched-length 1)
		 (set! matched-rule eof-action-num) )
	      ;;; on regarde ce qu'on a deja matche...
	      'what-is-match-before) ) )
;*---- eob-transition -------------------------------------------------*/
   (define (eob-transition state-num)
      `(let ( (state ,state-num) )
	  (lambda (indice)
	     (set! indice (- indice (stream/rp-backward stream)))
	     (stream/rp-pickchar stream (stream/rp-backward stream))
	     (let ( (res (stream/rp-read! stream)) )
		(if res
	            ;;; on a lu des chars en plus, on continue la parsing
	            (run-state state 0)
	            ;;; on n'a rien lu de plus, on n'arrete
		    (if (= matched-length 0)
			,the-error) ) ) ) ) )
;*---- unmatch-transition ---------------------------------------------*/
   (define (unmatch-transition)
      `(lambda (indice)
	  'cant-match-any-more) )
;*---- declare-fleche -------------------------------------------------*/
   (define (declare-fleche fleche)
(let ((code
      (let ( (lettre (car fleche))
	     (move   (cadr fleche)) )
      `(vector-set! traux 
		    ,(char->ascii lettre)
		    ,(case (car move)
			((go)
			 `(lambda (indice)
			     (run-state ,(cadr move) (1+ indice)) ) )
			((accept-and-go)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move))
			     (run-state ,(caddr move) (1+ indice))) )
			((accept)
			 `(lambda (indice)
			     (set! matched-length 
				   (1+ (- indice (stream/rp-backward stream))))
			     (set! matched-rule ,@(cadr move)) ) ) ) ) ) )
)
;* (print "fleche: " fleche "  -- > ")  */
;* (display code)  */
;* (newline)  */
code))
;*---- declare-state --------------------------------------------------*/
   (define (declare-state indice trans)
      `(let ( (traux (make-vector *last-char* ,(unmatch-transition))) )
	  (vector-set! traux (char->ascii *eof-char*) ,(eof-transition indice))
	  (vector-set! traux (char->ascii *eob-char*) ,(eob-transition indice))
	  ,@(letrec ( (loop (lambda (tr)
			       (cond
				((null? tr)
				 '())
				((null? (car tr))
				 (loop (cdr tr)))
				(else
				 (cons (declare-fleche (car tr))
					(loop (cdr tr))) ) ) ) ) )
	      (loop trans) )
	  (vector-set! t-state ,indice traux) ) )
;*---- declare-transition ---------------------------------------------*/
   (define (declare-transition)
       (cons 'begin
             (letrec ( (loop (lambda (indice trans*)
				(if (null? trans*)
				    '()
				    (if (and (null? (caar trans*))
					     (null? (cdar trans*)))
					  (loop (1+ indice) (cdr trans*))
					  (cons (declare-state indice (car trans*))
						(loop (1+ indice) (cdr trans*))))))))
		(loop 0 transitions*) ) ) )
;*---- declare-action -------------------------------------------------*/
   (define (declare-action)
      `(begin
	  (vector-set! t-action 0 (lambda () ,the-error))
	  ,@(letrec ( (loop (lambda (indice action*)
			       (if (null? action*)
				   '()
				   (cons
				    `(vector-set! t-action 
						  ,indice 
						  (lambda () ,(car action*)))
				    (loop (1+ indice) (cdr action*)) ) ) ) ) )
	       (loop 1 action*) ) ) )
;*---- declare-eof-action ---------------------------------------------*/
   (define (declare-eof-action)
      `(vector-set! t-action eof-action-num (lambda () 'eof) ) )
;*---- declare-parsing-lambda -----------------------------------------*/
   (define (declare-parsing-lambda unmatch-rule-number)
      `(lambda ()
	  (when (stream/rp-empty-buffer? stream)
	        (stream/rp-read! stream) )
	  (set! matched-rule   0)
	  (set! matched-length 0)
	  (set! old-backward   (stream/rp-backward stream))
	  (run-state 0 old-backward)
	  (stream/rp-pickchar stream matched-length)
          ((vector-ref t-action matched-rule)) ) )
;*---- declare-specials-formes ----------------------------------------*/
   (define (declare-specials-formes)
      '((define (the-length)
	   matched-length)
	(define (the-string)
	   (substring buffer old-backward (+ old-backward matched-length)) )
	(define (ignore)
	   ((vector-ref my-self 1)) )
	(define (match-all-line)
	   "not implemented yet") 
	(define (first-unmatched-char)
	   (let ( (c (string-ref buffer (stream/rp-backward stream))) )
	      (stream/rp-pickchar stream 1)
	      c) ) ) )
;*---------------------------------------------------------------------*/
;*     define-automata                                                 */
;*---------------------------------------------------------------------*/
   `(let ( (t-action         (make-vector ,(+ 2 (length action*))))
	   (stream           'dummy)
	   (buffer           'dummy)
	   (matched-length   0)
	   (matched-rule     0)
	   (old-backward     'dummy)
	   (eof-action-num   ,(1+ (length action*)))
	   (t-state          (make-vector ,nb-states))
	   (my-self          (make-vector 2)) )
;*---- et hop, on genere le code --------------------------------------*/
       ,@(declare-specials-formes) 
       ,(declare-action)
       ,(declare-eof-action)
       ,(declare-transition)
;*---- slot 0 ---------------------------------------------------------*/
       (vector-set! my-self 0 (lambda (new-stream)
				 (set! stream new-stream)
				 (set! buffer (stream/rp-buffer new-stream))))
;*---- slot 1 ---------------------------------------------------------*/
       (vector-set! my-self 1 ,(declare-parsing-lambda accept-0?))
;*---- Et ziou, c'est fini --------------------------------------------*/
       my-self) )

;*---------------------------------------------------------------------*/
;*     expand-transition ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-transition what)
   (let ( (fun (car what)) )
      (case fun
          (go
	   `((,symbol-append `state- ,(cadr what))) )
	  (accept-and-go
	   `(begin
	       (set! the-matched-rule ,@(cadr what))
               ((,symbol-append `state- ,(caddr what)) (+1 indice)) ) )
	  (accept
	   `(begin
	       (set! the-matched-rule ,@(car what))
	       indice)) ) ) )

;*---------------------------------------------------------------------*/
;*     automata ...                                                    */
;*   ---------------------------------------------------------------   */
;*   t-state-type est tableau (augmente au fur et a mesure) qui        */
;*   des cons (accept-action* . leave-out?)                            */
;*   ---------------------------------------------------------------   */
;*   accept-action* est une variable qui indique si un etat est        */
;*   acceptant et si oui, contient la liste (triee par ordre croissant)*/
;*   des actions semantiques.                                          */
;*   ---------------------------------------------------------------   */
;*   leave-out? indique si des transitions partent d'un etat.          */
;*---------------------------------------------------------------------*/
(define (automata state* nb-states the-error action* trap)
   (print ":=> Generating Code     (nb-states: " nb-states ")")
   (let* ( (t-state-type    (make-vector nb-states))
	   (accept-action*  'dummy)
	   (leave-out?      'dummy) )
;*---- accept? --------------------------------------------------------*/
;*   Cette fonction fait deux effets de bords:                         */
;*      - un sur accept-action*                                        */
;*      - un sur leave-out?                                            */
;*---------------------------------------------------------------------*/
       (define (accept? state-num)
	  ;;; a-t-on deja calcule les caracteristiques de cet etat?
	  (choose (ref (vector-ref t-state-type state-num))
	     ;;; oui
             (begin
		(set! accept-action* (car ref))
		(set! leave-out?     (cdr ref))
		accept-action*)
	     ;;; non
	     (set! accept-action* '())
	     (set! leave-out? #f)
	     (letrec ( (loop (lambda (t*)
			  (if (null? t*)
			      (begin
				 (vector-set! t-state-type 
					      state-num 
					      (cons accept-action* leave-out?))
				 accept-action*)
			      (let ( (pr (car t*)) )
				 (if (null? (cdr pr))
					;;; Oui, cet etat est accepte (car pr)
				     (set! accept-action* 
					   (insort! (car pr) accept-action*) )
					;;; Cet etat est leave-out
				     (set! leave-out? #t))
				 (loop (cdr t*))) ) ) ) )
	     (loop (vector-ref state* state-num))) ) )
;*---- Le calcul des transitions --------------------------------------*/
       (define (transitions s)
	  (letrec ( (loop (lambda (l)
	     (if (null? l)
		 '()
		 (let ( (pr (car l)) )
		    (let ( (lettre    (car pr))
			   (new-state (cdr pr)) )
		       (if (null? new-state)
			   ;;; ici on ne fait rien pour les matchs. Ils sont traite
			   ;;; avant (lors de la tr vers cet etat.)
			   (cons '() (loop (cdr l)))
			   (cons 
			      (choose (a* (accept? new-state))
				      (if leave-out?
					  (list lettre `(accept-and-go ,a* 
								       ,new-state))
					  (list lettre `(accept ,a*)) )
				      (if leave-out?
					  (list lettre `(go ,new-state))
					  '()) )
			      (loop (cdr l)) ) ) ) ) ) ) ) )
             (loop s) ) )
;*---- construction de l'automate -------------------------------------*/
       (define-automata
           nb-states
           (choose (num (accept? 0))
		   num
		   0)
           action*
	   the-error
           trap
           (letrec ( (trans-loop (lambda (indice)
              (if (= indice nb-states)
                  '()
		  (let ( (pr (vector-ref state* indice)) )
                     (choose (tr (transitions pr))
                        (cons tr (trans-loop (1+ indice)))
                        (trans-loop (1+ indice)) ) ) ) ) ) )
  	     (trans-loop 0) ) ) ) )

		       




;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/dfa.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri Apr 19 17:20:21 1991                          */
;*    Last change :  Thu May  2 16:03:53 1991  (serrano)               */
;*                                                                     */
;*    Le calcul des transitions du DFA                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     statistiques                                                    */
;*---------------------------------------------------------------------*/
(define statistique #t)

(define-macro (set-stat var val)
   `(if statistique
	(set! ,var ,val) ) )

(define t0               'dummy)
(define t1               'dummy)
(define nb-assq-union     0)
(define nb-assq-states    0)
(define nb-trivial        0)
(define nb-union          0)
(define nb-found-in-union 0)
(define nb-state          0)
(define nb-found-in-state 0)

(define (raz-stat)
   (set! t0               'dummy)
   (set! t1               'dummy)
   (set! nb-assq-union     0)
   (set! nb-assq-states    0)
   (set! nb-trivial        0)
   (set! nb-union          0)
   (set! nb-found-in-union 0)
   (set! nb-found-in-state 0)
   (set! nb-state          0) )

(define (get-stat)
   (print "time: " (- t1 t0) " s.")
   (print "nb-trivial    : " nb-trivial)
   (print "nb-assq-union : " nb-assq-union)
   (print "nb-assq-states: " nb-assq-states) 
   (print "nb-union      : " nb-union)
   (print "found-in-union: " nb-found-in-union)
   (print "nb-state      : " nb-state) 
   (print "found-in-state: " nb-found-in-state) )

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     make-prefix-name ...                                            */
;*---------------------------------------------------------------------*/
(define (make-prefix-name prefix num*)
   (string->symbol (apply 
		    string-append
		    (cons prefix
			  (map (lambda (num)
				  (string-append "." (number->string num) ) )
			       num*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     make-state-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-state-name num*)
   `(begin
       (set-stat nb-state (+ 1 nb-state))
       (make-prefix-name "state" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     make-union-name ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (make-union-name num*)
   `(begin
       (set-stat nb-union (+ 1 nb-union))
       (make-prefix-name "union" ,num*) ) )

;*---------------------------------------------------------------------*/
;*     dfa ...                                                         */
;*     ------------------------------------------------------------    */
;*     fast-union-v est passe en parametre car il a deja ete alloue    */
;*     (sa taille definitive est connue) par regular-grammar-2.        */
;*     ------------------------------------------------------------    */
;*     Toutes les unions triviales ne passent pas par les tables de    */
;*     hash mais sont retrouvees grace a un tableau (trivial).         */
;*     ------------------------------------------------------------    */
;*     t-alpha et l-alpha sont un tableau et une liste qui sont        */
;*     utilises pour calculer rapidement "lettre concernee a la pos".. */
;*     ------------------------------------------------------------    */
;*     l-trap est une liste qui contient toutes les traps. Une fois    */
;*     dstates calcule, on va gerer les traps. (passe trap)            */
;*---------------------------------------------------------------------*/
(define (dfa Dinit position f-store f-env egal fast-union-v l-trap action* error)
   (print ":=> Computing DFA")
   (raz-stat)
   (set-stat t0 (runtime))
   (let ( (Dstates-env   (make-env))
	  (Union-env     (make-env))
	  (nb-states-max 15)
	  (nb-states     -1)
	  (states        (make-vector 16))
	  (P=a           '()) 
	  (t-alpha       (make-vector *last-char*))
	  (l-alpha       '())
	  (trivial       (make-vector (vector-length f-store))) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*     ------------------------------------------------------------    */
;*     L'indirection f-env a deja ete faite dans union-followpos. il   */
;*     ne reste donc a faire que celle sur f-store.                    */
;*---------------------------------------------------------------------*/
       (define (fast-union l*)
	  (debug-print "fast-union: " l*)  
	  (if (null? (cdr l*))
	      (begin
		 (set-stat nb-trivial (+ 1 nb-trivial))
		 (vector-ref f-store (car l*)))
	      (let* ( (init (car (vector-ref f-store (car l*))))
		      (max  init)
		      (min  init) )
;*---- On lit toutes les listes ---------------------------------------*/
		 (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t) 
                                       (read (cdr l)) ) ) ) ) )
		    (letrec ( (loop (lambda (l)
				       (if (null? l)
					   'read-done
					   (begin
					      (read (vector-ref f-store (car l)))
					      (loop (cdr l)))))) )
		       (loop l*)) )
;*---- on ecrit le resultat -------------------------------------------*/
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) )
;*---- increment-nb-states --------------------------------------------*/
      (define (increment-nb-states)
	 (when (= nb-states nb-states-max)
	       (set! nb-states-max (* 2 nb-states-max))
	       (vector-extand states nb-states-max) )
	 (++ nb-states) )
;*---- make-state -----------------------------------------------------*/
      (define (make-state symbol-name)
         (define-in-env symbol-name (increment-nb-states) Dstates-env)
         nb-states)
;*---- set-alpha ------------------------------------------------------*/
;*   Si deux regles match une chaine, on ne prends que la 1ere action. */
;*   Pour modifier cela, il faut changer cette routine, ainsi que le   */
;*   code de main-loop a l'endroit on on fait:                         */
;*             (vector-set! dstates ... (cons a U) ...)                */
;*---------------------------------------------------------------------*/
      (define (set-alpha p*)
	 (set! l-alpha '())
	 (letrec ( (loop (lambda (p*)
		      (if (null? p*)
			  '()
			  (let ( (pr  (car p*))
				 (sp* (cdr p*)) )
			     (let* ( (lettre (vector-ref position pr))
				     (indice (if (char? lettre)
						 (char->integer lettre)
						 0)) )
				(cond
				 ((null? (vector-ref t-alpha indice))
				  (set! l-alpha (cons lettre l-alpha))
				  (vector-set! t-alpha indice (cons pr '()))
				  (loop sp*))
				 (else
				  (vector-set! t-alpha 
					       indice 
					       (cons pr 
						     (vector-ref t-alpha indice)))
				  (loop sp*))) ) ) ) ) ) )
	    (loop (reverse p*)) ) )
;*---- compute-real-union ---------------------------------------------*/
;*  Je garde cette fonction car je ne desepere pas de trouver une ruse */
;*  qui me permettrait une optimisation d'enfer...                     */
;*---------------------------------------------------------------------*/
      (define (compute-real-union position*)
	 (define (first-non-null? p* acc)
	    (if (null? p*)
		(reverse! acc)
		(if (null? (vector-ref f-store (car p*)))
		    (first-non-null? (cdr p*) acc)
		    (first-non-null? (cdr p*) (cons (car p*) acc)))))
	 (choose (p* (first-non-null? position* '()))
		 (fast-union p*)
		 '()) )
;*---------------------------------------------------------------------*/
;*     dfa                                                             */
;*---------------------------------------------------------------------*/
      (letrec ( (main-loop (lambda (dstates)
;*---- union-followpos ------------------------------------------------*/
;*  !!! WARNING !!!                                                    */
;*  ----------------------------------------------------------------   */
;*  C'est tres crade (mais efficace !), on fait un horrible            */
;*  side-effect sur dstates...                                         */
;*  ----------------------------------------------------------------   */
;*  On ne calcule pas union-followpos sur position* mais sur:          */
;*  (map f-env position*).                                             */
;*---------------------------------------------------------------------*/
         (define (union-followpos position*)
	    (let ( (env-pos (map (lambda (p) (vector-ref f-env p)) position*)) )
	       (debug-print "env-pos: " env-pos)
	       (when debug (read-char))
;*---- La gestion des triviaux ----------------------------------------*/
	       (cond
		((null? (cdr env-pos))
		 (let ( (indice (car env-pos)) )
		    (if (null? (vector-ref f-store indice))
			(begin
			   (debug-print "end-of-rule")
			   '())
			(begin
			   (debug-print "cas trivial: indice: " indice)
			   (set-stat nb-trivial (1+ nb-trivial))
			   (if (null? (vector-ref trivial indice))
			       (let ( (state-name (make-state-name 
						   (vector-ref f-store indice))) )
				  (debug-print "vector-ref null: " state-name)
				  (choose (num (bound? state-name Dstates-env))
					  (begin (vector-set! trivial indice num)
						 num)
					  (let ( (num (make-state state-name)) )
					     (vector-set! trivial indice num)
					     (set! dstates 
						   (cons (cons 
							  (vector-ref f-store indice) 
							  num) 
							 dstates))
					     num) ) )
			       (vector-ref trivial indice) ) ) )))
;*---- Les cas non-triviaux -------------------------------------------*/
		 (else
		  (let ( (union-name (make-union-name env-pos)) )
		     (set-stat nb-assq-union (+ 1 nb-assq-union))
		     (choose (num (bound? union-name Union-env))
			     (begin
				(set-stat nb-found-in-union (1+ nb-found-in-union))
				num)
			     (let* ( (U          (compute-real-union env-pos))
				     (state-name (make-state-name U)) )
(debug-print state-name)
                                  (set-stat nb-assq-states (+ 1 nb-assq-states))
				  (choose (num (bound? state-name Dstates-env))
					  (begin
					     (set-stat nb-found-in-state
						       (1+ nb-found-in-state))
					     (define-in-env union-name num Union-env) )
					  (let ( (num (make-state state-name)) )
					     (set! dstates (cons (cons U num) 
								 dstates))
					     (define-in-env 
						union-name 
						num 
						Union-env) ) ) ) ) ) ) ) ) )
;*---- main-loop ------------------------------------------------------*/
(debug-print "main-loop: " dstates)
         (if (null? dstates)
	     (begin
		(set-stat t1 (runtime))
		(automata states 
			  (1+ nb-states )
			  error 
			  action*
			  (trap nb-states l-trap trivial position f-env f-store) ) )
	     (let* ( (T    (car (car dstates)))
		     (Tnum (cdr (car dstates))) )
		(set-alpha T)                 ; on met en place t-alpha et l-alpha
		(set! dstates (cdr dstates))  ; Ceci revients a marquer dstates
;* (debug-print "l-alpha: " l-alpha)  */
;* (debug-print "t-alpha: " t-alpha)  */
		(letrec ( (loop (lambda (a*)
                             (if (null? a*)
				 (main-loop dstates)
				 (let* ( (a (car a*)) 
					 (indice (if (char? a) 
						     (char->integer a)
						     0)) )
(debug-print "loop: lettre: " a "    Tnum: " Tnum "   indice: " indice )
                                    (set! P=a (vector-ref t-alpha indice))
                                    (vector-set! t-alpha indice '())
				    (debug-print "P=a: " P=a)
				    (let ( (U (union-followpos P=a)) )
				       (debug-print "U: " U)
				       (vector-set! states 
						    Tnum 
						    (cons (cons a U) 
							  (vector-ref states Tnum)) ) )
				    (loop (cdr a*))) ) ) ) )
		   (loop l-alpha) ) ) ) ) ) ) 
	 (main-loop (list (cons Dinit (make-state (make-state-name Dinit)))) ) ) ) )
		       
			      

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/essai.scm ...                              */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:36:41 1991                          */
;*    Last change :  Thu May  2 17:07:48 1991  (serrano)               */
;*                                                                     */
;*    Un petit fichier d'essai                                         */
;*---------------------------------------------------------------------*/

(define rp 

;* (regular-grammar ()  */
;*    ( ( (* (! #\a #\b)) #\a #\b #\b) (print "length: " (the-length)))  */
;*    ( (#\Newline) (ignore)) )  */

(regular-grammar ( (chiffre (>-< #\0 #\9))
		   (lettre  (>-< #\a #\z)) )
   ( (#\Newline) (ignore))		 
   ( (+ chiffre) (print "un nombre: " (the-string) 
			" len: " (the-length))) )

;* (regular-grammar ()  */
;*      ( (#\; (* (all))) 'comment)  */
;*      ( (#\.)  'done) )  */

;* (regular-grammar ((chiffre (>-< #\0 #\9))  */
;* 		  (lettre  (>-< #\A #\z))  */
;* 		  (special (in #\. #\- #\+ #\_ #\? #\! #\=)))  */
;*    ( (! "define" "cond" "case" "set!" "eq?" "lambda") 'keyword)  */
;*    ( (lettre (* (! chiffre lettre special))) 'id)  */
;*    ( ((* chiffre) #\. (* chiffre)) 'float)  */
;*    ( (+ chiffre) 'integer) )  */

;* (regular-grammar()  */
;*    ( toto (>-< #\a #\b) 'ok)  */
;*    ( ("ab") 'ko) )  */

;* (regular-grammar ()  */
;*    ( ("ta") (print "je matche \"ta\"")   */
;*             (print "the-string: " (the-string))  */
;*             (print "the-length: " (the-length))   */
;* 	    (ignore) )  */
;*    ( ("ti") 'ti)   */
;*    ( (#\Newline) (print "\\n") (ignore))   */
;*    (else    (print "erreur on: " (first-unmatched-char)) ) )  */



;* (regular-grammar ()  */
;*    ( (#\a) 'a)   */
;*    ( (#\b) 'b)   */
;*    ( (#\c) 'c) )  */

)

(use-regular-parser rp)
(define st (make-stream/rp 1024))
(use-stream st)


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/expand.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 11:07:53 1991                          */
;*    Last change :  Thu May  2 16:06:12 1991  (serrano)               */
;*                                                                     */
;*    L'expansion des regles rationnelles                              */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La valeur du dernier caractere                                  */
;*---------------------------------------------------------------------*/
(define-constant *last-char*  128)
(define-constant *first-char* 3)
(define eof-action-num        #f)

;*---------------------------------------------------------------------*/
;*     La gestion de l'environment des regular-grammar                 */
;*---------------------------------------------------------------------*/
;*---- lookup ---------------------------------------------------------*/
(define-macro (lookup var env)
   `(assq ,var ,env) )

(define-macro (expanded? b)
   `(eq? (cadr ,b) #t) )

(define-macro (binding-ref b)
   `(caddr ,b) )

(define-macro (expand-binding! b env)
   `(set-cdr! ,b (list #t (expand (cadr ,b) env)) ) )

;*---------------------------------------------------------------------*/
;*     expand ...                                                      */
;*                                                                     */
;*     Cette fonction construit, a partir d'une expression utilisateur */
;*     une s-exp qui, lorqu'elle sera evaluer (voir regular-grammar-2) */
;*     retournera l'arbre syntaxique.                                  */
;*     Cette fonction est en fait une "demie-macro". Demie car elle se */
;*     contente de construire le texte, elle ne l'evalue pas.          */
;*                                                                     */
;*     L'expansion complete est effectuee ici (i.e. La syntaxe         */
;*     utilisateur est totalement definie par expand).                 */
;*                                                                     */
;*     Toutes fois, une fausse expansion est calculee dans             */
;*     tree-and-action. C'est l'expansion du ou global a toutes les    */
;*     regles...                                                       */
;*                                                                     */
;*     Lors de l'evaluation de la s-exp "tree" on a besoin d'une       */
;*     evaluation particuliere. Les arguments doivent etre evalues de  */
;*     gauche a droite. Pour certaines fonctions (reg-cat par ex.) on  */
;*     a besoin de faire un traitement avant l'evaluation de args.     */
;*     Pour ces 2 raisons on utilise DELAY. ici (cat e1 e2) sera       */
;*     expansee:  (reg-cat (delay e1) (delay e2))                      */
;*---------------------------------------------------------------------*/
(define (expand reg env)
;*---- check-arity? ---------------------------------------------------*/
   (define (check-arity? args num)
      (if (= (length args) num)
	  #t
	  (wrong "wrong number of arguments in " args) ) )
;*---- expand-delay ---------------------------------------------------*/
   (define (expand-delay op liste)
      (letrec ( (loop (lambda (l)
			 (if (null? l)
			     '()
			     (if (null? (cdr l))
				 (expand (car l) env)
				 (list op
				       `(delay ,(expand (car l) env))
				       `(delay ,(loop (cdr l))) ) ) ) ) ) )
	      (loop liste) ) )
;*---- construct-intervals --------------------------------------------*/
   (define (construct-intervals b*) ; Cette fonction est utilisee par
      (define (inter min max)       ; expand<-> et expand >-<. Elle
	 (if (eqv? min max)         ; retourne une liste d'INTEGER
	     `(,min)                ;                      -------
	     (cons min (inter (1+ min) max) ) ) )
      (if (null? b*)
	  '()
          (append (inter (char->integer (car b*)) (char->integer (cadr b*))) 
		  (construct-intervals (cddr b*))) ) )
;*---- expand-! -------------------------------------------------------*/
   (define (expand-! args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-or args) ) )
;*---- expand-. -------------------------------------------------------*/
   (define (expand-. args)
      (if (null? (cdr args))
	  (expand (car args) env)
	  (expand-delay 'reg-cat args) ) )
;*---- expand-string --------------------------------------------------*/
   (define (expand-string string)
      (expand-delay 'reg-cat-char 
		    (let ( (i 0) 
			   (j (string-length string)) 
			   (acc '()) )
		       (while (< i j)
			      (set! acc (cons (string-ref string i) acc))
			      (++ i) )
		       (reverse! acc))) )
;*---- expand<-> ------------------------------------------------------*/
   (define (expand<-> args)
      (let ( (i *first-char*)
	     (vexecpt 'dummy)
	     (fexecpt 'dummy)
	     (acc '()) )
	 (if (not (pair? args))
	     (begin
		(set! vexecpt (char->integer args))
		(set! fexecpt =) )
	     (begin
		(set! vexecpt (construct-intervals args))
		(set! fexecpt memq) ) )
	 (while (< i *last-char*)
		(unless (fexecpt i vexecpt)
		        (set! acc (cons (integer->char i) acc)) )
		(set! i (1+ i)) )
	     (set! acc (reverse! acc))
	     `(reg-in (quote ,acc) ) ) )
;*---- expand>-< ------------------------------------------------------*/
   (define (expand>-< args)
      (let ( (espace (construct-intervals args)) 
	     (acc '()) )
	 (while (not (null? espace))
		(set! acc (cons (integer->char (car espace)) acc))
		(set! espace (cdr espace)) )
	 (set! acc (reverse! acc))
	 `(reg-in (quote ,acc) ) ) )
;*---- expand ---------------------------------------------------------*/
   (if (not (pair? reg))
       (cond
	((char? reg) 
	 `(reg-char ,reg))
	((string? reg)
	 (if (> (string-length reg) 1) 
	     (expand-string reg)
	     `(reg-char ,(string-ref reg 0)) ) )
	(else
	 (choose (b (lookup reg env))
		    (begin
		       (if (not (expanded? b))
			   (expand-binding! b env))
		       (binding-ref b))
		    (wrong "Unbound variable " reg) ) ) )
       (let ( (op (car reg))
	      (args (cdr reg)) )
	  (if (null? args)
	      (case op
		 ((all)  (expand<-> #\Newline))
		 (else   (expand op env) ) )
	      (case op
		 ((*)    (if (number? (car args))
			     (if (check-arity? args 2) 
				 (wrong "not implemented yet..") )
			     (if (check-arity? args 1)
				 `(reg-* (delay ,(expand (car args) env)) ) ) ) )
		 ((+)    (if (number? (car args))
			     (if (check-arity? args 2)
				 (wrong "not implemented yet..") )
			     `(reg-+ (delay ,(expand (car args) env)) ) ) )
		 ((?)    (if (check-arity? args 1)
			     `(reg-01 (delay ,(expand (car args) env)) ) ) )
		 ((!)    (expand-! args))
		 ((>-<)  (if (even? (length args))
			     (expand>-< args)
			     (wrong "wrong number of arguments in " reg)) )
		 ((<->)  (if (null? (cdr args))
			     (expand<-> (car args))
			     (if (even? (length args))
				 (expand<-> args)
				 (wrong "wrong number of arguments in " reg)) ) )
		 ((in)   `(reg-in (quote ,args)))
		 ((out)   (let ( (i *first-char*)
				 (acc '()) )
			     (while (< i *last-char*)
				    (unless (memq i args)
					    (set! acc (cons (integer->char i) acc)) )
				    (set! i (1+ i)) )
			     (set! acc (reverse! acc))
			     `(reg-in (quote  ,acc) ) ) )
		 ((bol)     (if (check-arity? args 1)
				(list 'reg-bol (list 'delay (expand (car args) env)))))
		 ((eof)     (if (check-arity? args 1)
				(list 'reg-eof (list 'delay (expand (car args) env)))))
		 ((eol)     (if (check-arity? args 1)
				(list 'reg-eol (list 'delay (expand (car args) env)))))
		 ((marker)  (if (check-arity? args 1)
				`(reg-end ,(car args)) ))
		 ((context) (if (check-arity? args 2)
				(list 'reg-context 
				  `(quote ,(car args) )
				  (list 'delay (expand (cadr args) env))) ) )
		 (else   (expand-. reg)) ) ) ) ) )
				 
				    
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/include.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 10:35:49 1991                          */
;*    Last change :  Mon Apr 22 10:37:04 1991  (serrano)               */
;*                                                                     */
;*    Les macros qui ne peuvent etre definies dans les fichiers        */
;*    ou elles sont utilisess..                                        */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La structure de node ...                                        */
;*---------------------------------------------------------------------*/
(defstruct node firstpos 
                lastpos 
		nullable? 
		f-for-f
		l-for-f)

;*---- node-set! (macro d'affectation generalisee) --------------------*/
(define-macro (node-set! node first last nullable? f-for-f l-for-f)
   `(begin
       (node-firstpos-set!  ,node ,first)
       (node-lastpos-set!   ,node ,last)
       (node-nullable?-set! ,node ,nullable?) 
       (node-f-for-f-set!   ,node ,f-for-f)
       (node-l-for-f-set!   ,node ,l-for-f) ) )







;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/macros.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:54:29 1991                          */
;*    Last change :  Mon Apr 29 17:08:45 1991  (serrano)               */
;*                                                                     */
;*    La definition de toutes les nouvelles formes syntaxiques         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     debug-print ...                                                 */
;*---------------------------------------------------------------------*/
(define debug #f)
(define-macro (debug-print . l)
   `(when debug
	 (print ,@l)))

;*---------------------------------------------------------------------*/
;*     wrong ...                                                       */
;*---------------------------------------------------------------------*/
(define (wrong e1 e2)
   (print "*** ERROR: " e1)
   (print e2) 
   (error '()) )
   
;*---------------------------------------------------------------------*/
;*     choose ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (choose binding alors . sinon)
   `(let (,binding)
       (if ,(car binding)
	   ,alors
	   ,(if sinon
		`(begin ,@sinon)
		#f) ) ) )

;*---------------------------------------------------------------------*/
;*     when ...                                                        */
;*---------------------------------------------------------------------*/
(define-macro (when si . alors)
   `(if ,si 
        (begin ,@alors)
        #f) )

;*---------------------------------------------------------------------*/
;*     unless ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (unless si . sinon)
   `(if ,si
        #f
        (begin ,@sinon) ) )

;*---------------------------------------------------------------------*/
;*     while ...                                                       */
;*---------------------------------------------------------------------*/
(define-macro (while si . alors)
   `(letrec ( (loop (lambda () 
		       (begin ,@alors
			      (when ,si
				    (loop) ) ) ) ) )
       (loop) ) )

;*---------------------------------------------------------------------*/
;*     for ...                                                         */
;*---------------------------------------------------------------------*/
(define-macro (for bindings pred increment body . res)
   `(let ,bindings 
       (while ,pred
          (begin
	     ,body
	     ,increment) )
       ,(if res
	   (cons 'begin res)
	   #f) ) )

;*---------------------------------------------------------------------*/
;*     ++ ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (++ var)
   `(begin
       (set! ,var (1+ ,var))
       ,var) )

;*---------------------------------------------------------------------*/
;*     -- ...                                                          */
;*---------------------------------------------------------------------*/
(define-macro (-- var)
   `(begin
       (set! ,var (1- ,var))
       ,var) )
	
;*---------------------------------------------------------------------*/
;*     print ...                                                       */
;*---------------------------------------------------------------------*/
(define (print . args)
   (for-each display args)
   (newline) )

;*---------------------------------------------------------------------*/
;*     prin ...                                                       */
;*---------------------------------------------------------------------*/
(define (prin . args)
   (for-each display args) )

;*---------------------------------------------------------------------*/
;*     defstruct ...                                                   */
;*---------------------------------------------------------------------*/
(define-macro (defstruct nom . fields)
   (let ()
      (define symbol-append (access symbol-append user-initial-environment))
      (define *compteur-defstruct* -1)
      (define (give-ref)
	 (set! *compteur-defstruct* (1+ *compteur-defstruct*))
	 *compteur-defstruct*)
      (cons 'begin
	    (cons
	     `(define-macro 
		 ,(list (symbol-append nom '-new))
		 ,(list 'quote (list 'make-vector (length fields) '' () ) ) )
	     (apply append
                (map
		 (lambda (field)
		    (let ( (name-ref (symbol-append nom '- field))
			   (name-set (symbol-append nom '- field '-set!))
			   (ref      (give-ref)) )
		       (list `(define-macro ,(list name-ref 'nom)
				 ,(list 
				   'quasiquote
				   (list 'vector-ref
					 '(unquote nom)
					 ref)) )
			     `(define-macro ,(list name-set 'nom 'value)
				 ,(list
				   'quasiquote
				   (list 'vector-set!
					 '(unquote nom)
					 ref
					 '(unquote value))) ) ) ) )
		 fields) ) ) ) ) )

;*---------------------------------------------------------------------*/
;*     rplacd! ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (rplacd! l quoi)
   `(begin
       (set-cdr! ,l ,quoi)
       ,l) );*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/make.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 15:31:43 1991                          */
;*    Last change :  Tue Apr 30 09:59:46 1991  (serrano)               */
;*                                                                     */
;*    Le loader de read/rp                                             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     La liste des fichiers                                           */
;*---------------------------------------------------------------------*/
(define file* '("macros" 
		"include"
		"mit"
		"dfa"
		"automata"
		"expand" 
		"trap"
		"regular-grammar" 
		"regular-grammar-1" 
		"regular-grammar-2"
		"read-rp"
		"stream") )

(define compiled-dir "./Compiled/")

;*---------------------------------------------------------------------*/
;*     lall ...                                                        */
;*---------------------------------------------------------------------*/
(define (lall . arg)
   (let ( (prefix (if (null? arg) "" compiled-dir)) )
      (for-each (lambda (f) (display "Loading: ")
			    (display (string-append prefix f))
			    (display "...") 
			    (load (string-append prefix f) )
			    (display "done.")
			    (newline) )
		(if (null? arg) 
		    file*
		    (delete "include" file*) ) ) ) )

;*---------------------------------------------------------------------*/
;*     call ...                                                        */
;*---------------------------------------------------------------------*/
(define (call)
   (for-each (lambda (f) (cf f compiled-dir)) (delete "include" file*) ) )
   
;*---------------------------------------------------------------------*/
;*     Les load particuliers                                           */
;*---------------------------------------------------------------------*/
(define (lrg)
   (load "regular-grammar") )

(define (lin)
   (load "include") )

(define (lmit)
   (load "mit") )

(define (ldfa)
   (load "dfa") )

(define (lrg1)
   (load "regular-grammar-1") )

(define (lrg2)
   (load "regular-grammar-2") )

(define (make)
   (load "make") )

(define (lma)
   (load "macros") )

(define (lex)
   (load "expand") )

(define (ltra)
   (load "trap") )

(define (lau)
   (load "automata") 
   (load "dfa") )

(define (les)
   (load "essai") )

(define (lst)
   (load "stream") )

(define (lrp)
   (load "read-rp") )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/mit.scm ...                                */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Mon Apr 22 09:55:14 1991                          */
;*    Last change :  Thu May  2 10:12:11 1991  (serrano)               */
;*                                                                     */
;*    Fichier 'Scheme-dependant' pour le MIT-Scheme                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     vector-extand ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (vector-extand vector new-size)
   `(set! ,vector (vector-grow ,vector (1+ ,new-size) ) ) )

;*---------------------------------------------------------------------*/
;*     bound? ...                                                      */
;*---------------------------------------------------------------------*/
(define-macro (bound? name env)
   `(choose (b (assq ,name ,env))
	    (cdr b)
	    #f) )

;*---------------------------------------------------------------------*/
;*     set-in-env! ...                                                 */
;*---------------------------------------------------------------------*/
(define-macro (set-in-env! name val env)
   `(let ( (b (assq ,name ,env))
	   (v ,val) )
       (set-cdr! b v)
       v) )

;*---------------------------------------------------------------------*/
;*     define-in-env ...                                               */
;*---------------------------------------------------------------------*/
(define-macro (define-in-env name val env)
   `(let ( (v ,val) )
       (set! ,env (cons (cons ,name v) ,env))
       v) )

;*---------------------------------------------------------------------*/
;*     make-env ...                                                    */
;*---------------------------------------------------------------------*/
(define-macro (make-env)
   () )

;*---------------------------------------------------------------------*/
;*     nth ...                                                         */
;*---------------------------------------------------------------------*/
(define (nth num liste)
   (letrec ( (loop (lambda (l n)
		      (cond 
		       ((null? l)
			(alert "***ERROR: list to small" liste))
		       ((= n num)
			(car l))
		       (else
			(loop (cdr l) (1+ n)))))) )
      (loop liste 1) ) )

;*---------------------------------------------------------------------*/
;*     last ...                                                        */
;*---------------------------------------------------------------------*/
(define (last l*)
   (if (null? l*)
       '()
       (letrec ( (loop (lambda (l)
			  (if (null? (cdr l))
			      l
			      (loop (cdr l))))))
	  (loop l*))))

;*---------------------------------------------------------------------*/
;*     insort! ...                                                     */
;*---------------------------------------------------------------------*/
(define (insort! quoi dans)
   (cond 
      ((null? dans) 
       (cons quoi '()))
      ((< quoi (car dans)) 
       (rplacd! dans (insort! quoi (cdr dans))))
      (else
       (set-cdr! dans (cons (car dans) (cdr dans)))
       (set-car! dans quoi)
       dans)) )

;*---------------------------------------------------------------------*/
;*     define-constant ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (define-constant var val)
   `(define ,var ,val) )

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/read-rp.scm ...                            */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:54:50 1991                          */
;*    Last change :  Thu May  2 12:36:00 1991  (serrano)               */
;*                                                                     */
;*    Les nouvelles syntaxes                                           */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     les variables globales                                          */
;*---------------------------------------------------------------------*/
(define *the-current-regular-parser* #f)

;*---------------------------------------------------------------------*/
;*     use-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (use-regular-parser rp)
   `(set! *the-current-regular-parser* ,rp) )

;*---------------------------------------------------------------------*/
;*     use-stream ...                                                  */
;*---------------------------------------------------------------------*/
(define-macro (use-stream stream)
   `((vector-ref *the-current-regular-parser* 0) ,stream) )

;*---------------------------------------------------------------------*/
;*     read/rp ...                                                     */
;*---------------------------------------------------------------------*/
(define-macro (read/rp)
   '((vector-ref *the-current-regular-parser* 1)) )
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-1.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 16:55:07 1991                          */
;*    Last change :  Fri May  3 09:04:35 1991  (serrano)               */
;*                                                                     */
;*    La deuxieme phase de compilation des regular-grammar             */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-1 ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-1 error . rules*)
   (let ( (tree-and-action (access tree-and-action user-initial-environment)) )
      `(regular-grammar-2 ,error ,@(tree-and-action rules*)) ) )

;*---------------------------------------------------------------------*/
;*     tree-and-action ...                                             */
;*---------------------------------------------------------------------*/
(define (tree-and-action rules*)
   (if (null? (cdr rules*))
       (list (caar rules*) (cdr (car rules*)))
       (let ( (action '())
	      (rules '()) )
          (letrec ( (loop (lambda (r*)
			 (let ( (r (car r*)) )
			    (if (null? (cdr r*))
				(begin
				   (set! action (cons (cadr r) action))
				   (car r))
				(begin
				   (set! action (cons (cadr r) action))
				   `(reg-or (delay ,(car r)) 
					    (delay ,(loop (cdr r*)))) ) ) ) ) ) )
	     (set! rules (loop rules*))
	     (list rules action) ) ) ) )
				    


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar-2.scm ...                  */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:22:36 1991                          */
;*    Last change :  Thu May  2 16:03:41 1991  (serrano)               */
;*                                                                     */
;*    La troisieme phase de compilation des regular-grammar            */
;*    (Cette phase correspond en fait au calcul du dfa)                */
;*---------------------------------------------------------------------*/


;*---------------------------------------------------------------------*/
;*     regular-grammar-2 ...                                           */
;*                                                                     */
;*     Cette macro construit l'environment dans lequel l'evaluation de */
;*     "tree" va donner l'arbre syntaxique. Autrement dit, toutes les  */
;*     fonctions "reg-???" sont definies dans le "let" de la macro et  */
;*     nulle part ailleurs.                                            */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     Les structures de constructions de l'arbre et du dfa sont:      */
;*        pos: position dans l'arbre syntaxique                        */
;*        position:   pos       --->  lettre                           */
;*        f-env:      pos       --->  location                         */
;*        f-store:    location  --->  pos*                             */
;*                                                                     */
;*     ------------------------------------------------------------    */
;*     La plus part des fonctions reg-??? font des effets de bords sur */
;*     walk. La valeur de walk est juste en entree et doit etre        */
;*     ajustee a la sortie. Toutes fois certaines fonctions ne font    */
;*     que consulter cette variable.                                   */
;*     ------------------------------------------------------------    */
;*     fast-union, comme son nom l'indique calcule l'union entre 2     */
;*     listes. fast-union utilise fast-union-v. fast-union-v croit     */
;*     comme f-env.                                                    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar-2 error tree action)
   (define dfa (access dfa user-initial-environment))
   (define print (access print user-initial-environment))
   (let ( (store-indice           -1)
	   (env-indice             -1)
	   (walk                   #f)
	   (trap*                  '())
	   (store-len              15)
	   (env-len                15)
	   (fast-union-v           (make-vector 16))
	   (position               (make-vector 16))
	   (f-env                  (make-vector 16))
	   (f-store                (make-vector 16))
	   (egal                   (make-vector 16)) )
;*---------------------------------------------------------------------*/
;*     fast-union                                                      */
;*---------------------------------------------------------------------*/
       (define (fast-union l1 l2)
(when (and (not (null? l1))
	   (not (null? l2)))
      (print "NOT BOTH NULL? in FAST-UNION (passe 2)") )
	  (if (null? l1)
	      l2
	      (if (null? l2)
		  l1
		  (let ( (max (car l1))
			 (min (car l1)) )
		     (letrec ( (read (lambda (l)
				(if (null? l)
				    '()
				    (let ( (c (car l)) )
				       (if (< c min)
					   (set! min c)
					   (if (> c max)
					       (set! max c) ) )
				       (vector-set! fast-union-v c #t)
				       (read (cdr l)) ) ) ) ) )
			(read l1)
			(read l2) )
		     (for ((i max) (acc '()))
			  (>= i min)
			  (set! i (- i 1))
			  (when (vector-ref fast-union-v i)
				(set! acc (cons i acc))
				(vector-set! fast-union-v i #f))
			  acc) ) ) ) )
;*---------------------------------------------------------------------*/
;*     double-position                                                 */
;*---------------------------------------------------------------------*/
       (define (double-position)
	  (set! env-len  (* 2 env-len))
	  (vector-extand position     env-len)
          (vector-extand f-env        env-len)
	  (vector-extand fast-union-v env-len) )
;*---------------------------------------------------------------------*/
;*     get-location                                                    */
;*---------------------------------------------------------------------*/
       (define (get-location)
	  (when (= store-indice store-len)
		(begin
		   (set! store-len (* 2 store-len))
		   (vector-extand f-store store-len) 
		   (vector-extand egal    store-len) ) )
	  (++ store-indice) )
;*---------------------------------------------------------------------*/
;*     get-new-pos                                                     */
;*---------------------------------------------------------------------*/
       (define (get-new-pos)
	  (when (= env-indice env-len)
	       (double-position) )
	  (++ env-indice) )
;*---------------------------------------------------------------------*/
;*     reg-or                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-or de1 de2)
	  (let ( (n1   (force de1))
		 (n2   'dummy) 
		 (node (node-new)) )
	     (set! n2 (force de2))
	     (node-set! node
			(append (node-firstpos n1) (node-firstpos n2))
			(append (node-lastpos n1) (node-lastpos n2))
			(or (node-nullable? n1) (node-nullable? n2))
			(append (node-f-for-f n1) (node-f-for-f n2))
			(append (node-l-for-f n1) (node-l-for-f n2)) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-cat                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-cat de1 de2)
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
	     (for-each 
	         (lambda(i)
		    (let ( (location (vector-ref f-env i)) )
		       (vector-set! f-store
				    location
				    (append (vector-ref f-store location)
					    (node-firstpos n2)) ) ) )
		 (node-l-for-f n1) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node
			(if (node-nullable? n1)
			    (append (node-firstpos n1)
				    (node-firstpos n2))
			    (node-firstpos n1))
			(if (node-nullable? n2)
			    (append (node-lastpos n2)
				    (node-lastpos n1))
			    (node-lastpos n2))
			(and (node-nullable? n1) (node-nullable? n2))
			(if (node-nullable? n1)
			    (append (node-f-for-f n1)
				    (node-f-for-f n2))
			    (node-f-for-f n1))
			(if (node-nullable? n2)
			    (append (node-l-for-f n2)
				    (node-l-for-f n1))
			    (node-l-for-f n2)) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-cat-char                                                    */
;*     !!! Attention !!! Il faut verifier cette fonction ...           */
;*---------------------------------------------------------------------*/
       (define (reg-cat-char de1 de2) 
          (let ( (n1  'dummy)
		 (n2  'dummy)
		 (node (node-new)) 
		 (waux walk) )
;*---- on calcule les 2 fils ------------------------------------------*/
	     (set! walk #f)
	     (set! n1 (force de1))
	     (set! walk waux)
	     (set! n2 (force de2))
;*---- on calcule follow ----------------------------------------------*/
             (let ( (i (car (node-l-for-f n1))) )
		(let ( (location (vector-ref f-env i)) )
		   (vector-set! f-store
				location
				(append (vector-ref f-store location)
					(node-firstpos n2)) ) ) )
;*---- on calcule la racine resultante --------------------------------*/
	     (node-set! node (node-firstpos n1) 
			     (node-lastpos n2) 
			     #f
			     (node-f-for-f n1)
			     (node-l-for-f n2) )
             node) )
;*---------------------------------------------------------------------*/
;*     reg-in                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-in char*)
	  (if (null? (cdr char*))
	      (reg-char (car char*))
	      (let* ( (node (reg-char (car char*)))
 		      (pos* (reverse! (letrec ( (l (lambda (c acc)
					   (if (null? c)
					       acc
					       (l (cdr c) (cons (get-new-pos) acc))))))
			      (l (cdr char*) '()))) ) )
		 (node-firstpos-set! node (append (node-firstpos node) pos*))
		 (node-lastpos-set!  node (append (node-lastpos node) pos*))
		 (vector-set! egal walk (append (vector-ref egal walk) pos*))
		 (letrec ( (loop (lambda (c* pos*)
				    (if (null? c*)
					node
					(begin
					   (let ( (pos (car pos*)) )
					      (vector-set! position pos (car c*))
					      (vector-set! f-env pos walk) )
					   (loop (cdr c*) (cdr pos*)) ) ) ) ) )
		    (loop (cdr char*) pos*) ) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-char                                                        */
;*---------------------------------------------------------------------*/
       (define (reg-char char)
	  (let ( (node (node-new))
		 (pos  (get-new-pos)) )
	     (vector-set! position pos char)
	     (if walk
		 (begin
		    (vector-set! f-env  pos walk)
		    (vector-set! egal walk (cons pos (vector-ref egal walk)))
		    (node-set! node (list pos) (list pos) #f '() '()) )
		 (let ( (location (get-location)) )
		    (vector-set! f-env pos location)
		    (vector-set! f-store location '())
		    (set! walk location)
		    (vector-set! egal walk (list pos))
		    (node-set! node (list pos) (list pos) #f (list pos) (list pos)) ) )
	     node) )
;*---------------------------------------------------------------------*/
;*     compute-follow-*+01                                             */
;*---------------------------------------------------------------------*/
       (define (compute-follow-*+01 node)
          (let ( (firstpos (node-firstpos node)) )
	     (for-each 
	      (lambda (i)
		 (let ( (location (vector-ref f-env i)) )
		    (vector-set! f-store
				 location
				 (fast-union (vector-ref f-store location)
					     firstpos) ) ) )
	      (node-l-for-f node) ) ) )
;*---------------------------------------------------------------------*/
;*     reg-*                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-* de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     #t 
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-+                                                           */
;*---------------------------------------------------------------------*/
       (define (reg-+ de) 
          (set! walk #f)
          (let ( (n    (force de)) 
		 (node (node-new)) )
	     (compute-follow-*+01 n)
	     (set! walk #f)
	     (node-set! node (node-firstpos n) 
			     (node-lastpos n) 
			     (node-nullable? n)
			     (node-f-for-f n)
			     (node-l-for-f n) )
	     node) )
;*---------------------------------------------------------------------*/
;*     reg-01                                                          */
;*---------------------------------------------------------------------*/
       (define (reg-01 e) 
	  (print "?") )
;*---------------------------------------------------------------------*/
;*     reg-end                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-end num) 
          (reg-char num) )
;*---------------------------------------------------------------------*/
;*     reg-bol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-bol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(bol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eol                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eol de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eol ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-eof                                                         */
;*---------------------------------------------------------------------*/
       (define (reg-eof de) 
          (let ( (n (force de)) )
	     (set! trap* (cons `(eof ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     reg-context                                                     */
;*---------------------------------------------------------------------*/
       (define (reg-context context de)
          (let ( (n (force de)) )
	     (set! trap* (cons `(context ,context ,n) trap*) )
	     n) )
;*---------------------------------------------------------------------*/
;*     regular-grammar-2                                               */
;*---------------------------------------------------------------------*/
      (print ":=> Eval tree")
       (let ( (tree (eval tree (the-environment))) )
;* 	  (newline)  */
;* 	  (print "-----------------------")  */
;* 	  (print "nb-position: " (+ 1 store-indice))  */
;* 	  (print "nb-env     : " (+ 1 env-indice))  */
;* 	  (print "position: " position)  */
;* 	  (print "env     : " f-env)  */
;* 	  (print "store   : " f-store)  */
;* 	  (print "egal    : " egal)  */
;*        (print "trap*   : " trap*)  */
          (dfa (node-firstpos tree) 
	       position 
	       f-store 
	       f-env 
	       egal 
	       fast-union-v
	       trap*
	       action
	       error) ) ) )


;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/regular-grammar.scm ...                    */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Wed Apr 17 09:50:15 1991                          */
;*    Last change :  Thu May  2 15:29:04 1991  (serrano)               */
;*                                                                     */
;*    La definition des grammaires rationnelles.                       */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     regular-grammar ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (regular-grammar env . body)
   (let ( (expand-body (access expand-body user-initial-environment)) )
      `(regular-grammar-1 ,@(expand-body env body)) ) )

;*---------------------------------------------------------------------*/
;*     expand-body ...                                                 */
;*---------------------------------------------------------------------*/
(define (expand-body env body)
;*---- expand-rule ----------------------------------------------------*/
   (define (expand-rule rule marker env)
      (define (mark exp)
	 `(,exp (marker ,marker)))
      (if (pair? (car rule))
	  (list (expand (mark (car rule)) env)
		`(begin ,@(cdr rule)) )
	  (list (expand (mark `(context ,(car rule) ,(cadr rule))) env)
		`(begin ,@(cddr rule)) ) ) )
;*---- expand-body ----------------------------------------------------*/
   (letrec ( (parse-body
	         (lambda (b acc mark)
		    (if (null? b)
			(cons '(first-unmatched-char) acc)
			(let ( (rule (car b))
			       (rest (cdr b)) )
			   (if (eq? (car rule) 'else)
			       (if (null? rest)
				   (cons `(begin ,@(cdr rule)) acc)
				   (wrong "else is not the last clause of " body) )
			       (parse-body (cdr b) 
					   (cons (expand-rule rule mark env)
						 acc)
					   (1+ mark) ) ) ) ) ) ) )
      (parse-body body '() 1) ) )
					   ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/scheme.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 18 09:25:31 1991                          */
;*    Last change :  Thu May  2 17:25:34 1991  (serrano)               */
;*                                                                     */
;*    La grammaire scheme ...                                          */
;*---------------------------------------------------------------------*/

(define *scheme-parser*
      (regular-grammar ( (chiffre (>-< #\0 #\9))
			 (lettre  (>-< #\a #\z #\A #\Z))
			 (special (in #\. #\- #\+))
			 (id      ((! special lettre) 
				   (* (! lettre chiffre special)))) )
         ((#\Newline)
	  (ignore))
	 ((#\()
	  (print "par-open: 1")
	  (ignore))
	 ((#\))
	  (print "par-close: 1")
	  (ignore))
         ((#\; (* (all)))
	  (print "comment: " (the-length))
	  (ignore))
	 ((#\" (<-> #\") #\")
	  (print "string: " (the-length))
	  (ignore))
	 ((#\')
	  (print "quote: 1")
	  (ignore))
	 ((#\`)
	  (print "backquote: 1")
	  (ignore))
	 ((",@")
	  (print "unquote splicing: 1")
	  (ignore))
	 ((#\,)
	  (print "comma: 1")
	  (ignore))
	 ((! "define" "lambda" "set!" "cons" "cond" "begin" "let" "if")
	  (print "keyword: " (the-length))
	  (ignore))
	 ((id)
	  (print "id: " (the-length))
	  (ignore))
	 ((* chiffre)
	  (print "integer: " (the-length))
	  (ignore))
	 (((* chiffre) #\. (* chiffre))
	  (print "float: " (the-length))
	  (ignore))
	 (else
	  'erreur) ) )



(use-regular-parser *scheme-parser*)
(define st (make-stream/rp 1024 "automata.scm"))
(use-stream st)
;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/stream.scm ...                             */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Apr 30 09:48:54 1991                          */
;*    Last change :  Thu May  2 16:43:50 1991  (serrano)               */
;*                                                                     */
;*    Ma definition des input-stream                                   */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     Les constantes                                                  */
;*---------------------------------------------------------------------*/
(define-constant *eob-char* (ascii->char 0))
(define-constant *eof-char* (ascii->char 1))

;*---------------------------------------------------------------------*/
;*     make-stream/rp ...                                              */
;*   ---------------------------------------------------------------   */
;*   un stream/rp est un vecteur a 8 slots:                            */
;*     buffer         0                                                */
;*     buflen         1                                                */
;*     backward       2                                                */
;*     forward        3                                                */
;*     lambda-read    4                                                */
;*     lambda-close   5                                                */
;*     eof?           6                                                */
;*     pick-char      7                                                */
;*---------------------------------------------------------------------*/
(define (make-stream/rp buflen . name)
   (if (and name (not (file-exists? (car name))))
       (wrong "Unknown file: " (car name))
;*---- Les variables closes (+ buflen) --------------------------------*/
       (let ( (my-self  (make-vector 8))
	      (buffer   (make-string (1+ buflen) *eob-char*))
	      (backward 0)
	      (forward  0)
	      (eof?     #f)
	      (file     (if name (open-input-file (car name)) (current-input-port))) )
;*---- fread ----------------------------------------------------------*/
	  (define (fread offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not eof?))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (if (eof-object? getchar)
		         ;;; On lit un end-of-file
			 (begin  
			    (set! eof? #t)
			    (string-set! buffer forward *eof-char*) )
		         ;;; On lit un char normal
			 (string-set! buffer forward getchar) ) )
		  (> forward (1+ offset)) ) )
;*---- fread-to-eol ---------------------------------------------------*/
	  (define (fread-to-eol offset)
	     (for ((getchar #f))
		  (and (< forward buflen) (not (eqv? getchar #\Newline)))
		  (set! forward (1+ forward))
		  (begin
		     (set! getchar (read-char file))
		     (string-set! buffer forward *eof-char*) 
		     (string-set! buffer forward getchar) )
		  (> forward (1+ offset)) ) )
;*---- read-string ----------------------------------------------------*/
	  (define (read-string)
	     ;;; Si on a lu eof on ne peut rien lire de plus
	     (if eof?
		 #f
		 (begin
   	            ;;; La deuxieme chose a faire est de reajuster le buffer actuel
		    (when (> backward 0)
			  (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
			  (substring-move-left! buffer backward forward buffer 0)
			  (set! forward (- forward backward)) 
			  (set! backward 0) )
	            ;;; Le buffer est rewinde, on peut lire maintenant
		    (fread forward) ) ) )
;*---- read-string-from-console ---------------------------------------*/
	  (define (read-string-from-console)
	     (when (> backward 0)
		   (set! forward (1+ forward))  ;;; on ajoute 1 comme cela on a
  		                                       ;;; le *eob-char* qui est copie.
		   (substring-move-left! buffer backward forward buffer 0)
		   (set! forward (- forward backward)) 
		   (set! backward 0) )
	     ;;; Le buffer est rewinde, on peut lire maintenant
	     (fread-to-eol forward) )
;*---- On remplit les slots -------------------------------------------*/
	  (vector-set! my-self 0 buffer)
	  (vector-set! my-self 1 buflen)
	  (vector-set! my-self 2 (lambda () backward))
	  (vector-set! my-self 3 (lambda () forward))
	  (vector-set! my-self 4 (if name read-string read-string-from-console))
	  (vector-set! my-self 5 (lambda () (if name (close-input-port file))))
	  (vector-set! my-self 6 (lambda () eof?))
	  (vector-set! my-self 7 (lambda (nb) (set! backward (+ backward nb))))
	  my-self) ) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buffer ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buffer stream)
   `(vector-ref ,stream 0) )

;*---------------------------------------------------------------------*/
;*     stream/rp-buflen ...                                            */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-buflen stream)
   `(vector-ref ,stream 1) )

;*---------------------------------------------------------------------*/
;*     stream/rp-backward ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-backward stream)
   `((vector-ref ,stream 2)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-forward ...                                           */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-forward stream)
   `((vector-ref ,stream 3)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-read! ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-read! stream)
   `((vector-ref ,stream 4)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-close ...                                             */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-close stream)
   `((vector-ref ,stream 5)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-eof? ...                                              */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-eof? stream)
   `((vector-ref ,stream 6)) )

;*---------------------------------------------------------------------*/
;*     stream/rp-pickchar ...                                          */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-pickchar stream nb-char)
   `((vector-ref ,stream 7) ,nb-char))

;*---------------------------------------------------------------------*/
;*     stream/rp-empty-buffer? ...                                     */
;*---------------------------------------------------------------------*/
(define-macro (stream/rp-empty-buffer? stream)
   `(= (stream/rp-forward ,stream) (stream/rp-backward ,stream)) )

;*---------------------------------------------------------------------*/
;*     read-file ...                                                   */
;*   ---------------------------------------------------------------   */
;*   Ceci est un exemple de lecture d'un fichier avec les stream/rp..  */
;*---------------------------------------------------------------------*/
(define (read-file name)
   (let* ( (stream (make-stream/rp name 80)) 
	   (buffer (stream/rp-buffer stream)) )
      (while (not (stream/rp-eof? stream))
	     (print buffer)
	     (print "backward: " (stream/rp-backward stream))
	     (print "forward : " (stream/rp-forward stream))
	     (print "eof?    : " (stream/rp-eof? stream))
	     (read-char)
	     (stream/rp-pickchar stream (stream/rp-forward stream))
	     (stream/rp-read! stream) )
      (stream/rp-close stream) ) )
			       ;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/trap.scm ...                               */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Thu Apr 25 10:32:09 1991                          */
;*    Last change :  Mon Apr 29 15:20:17 1991  (serrano)               */
;*                                                                     */
;*    La gestion des traps ...                                         */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*     trap ...                                                        */
;*     ------------------------------------------------------------    */
;*     Les traps sont toujours inserer dans le (reg-cat exp marker)    */
;*     --> (reg-cat (trap exp) marker). Donc pour savoir a quelle      */
;*     action semantique correspond une trap il faut faire:            */
;*        ++last( lastpos node )                                       */
;*---------------------------------------------------------------------*/
(define (trap nb-states l-trap trivial position f-env f-store)
   'dummy)
   '''(unless (null? l-trap)
      (let ( (trap-transtion (make-vector (1+ nb-states)))
	     (trap-action    (make-vector 128)) )
;*---- trap-action ----------------------------------------------------*/
	 (define (trap-action etat action quoi)
	    (debug-print "trapping action:     etat: " etat)
	    (debug-print "                   action: " action)
	    (debug-print "                     quoi: " quoi) )
;*---- trap-transition ------------------------------------------------*/
	 (define (trap-transition etat lettre quoi)
	    (debug-print "trapping transition: etat: " etat)
	    (debug-print "                   lettre: " lettre)
	    (debug-print "                     quoi: " quoi) )
;*---- trivial? -------------------------------------------------------*/
	 (define (trivial? p)
	    (vector-ref trivial (vector-ref f-env p)) )
;*---- follow-in-min-max ----------------------------------------------*/
	 (define (follow-in-min-max min max p)
(debug-print "f-in-m-m: " p "  fol: " (vector-ref f-store (vector-ref f-env p)))
	    (let ( (p* (vector-ref f-store (vector-ref f-env p))) )
	       (letrec ( (loop (lambda (p* acc)
				  (if (null? p*)
				      (begin
					 (debug-print acc)
					 (reverse! acc))
				      (let ( (pr  (car p*)) )
					 (if (and (>= pr min)
						  (<= pr max))
					     (loop (cdr p*) (cons pr acc))
					     (loop (cdr p*) acc)) ) ) ) ) )
		  (loop p* '()) ) ) )
;*---- trap-context ---------------------------------------------------*/
	 (define (trap-context context node)
	    (let* ( (min    (car (node-firstpos node))) 
		    (max    (car (last (node-lastpos node))))
		    (action (vector-ref position (1+ max))) )
	       (debug-print "------------------------")
	       (debug-print "trap-context: " context )
	       (debug-print "min         : " min)
	       (debug-print "max         : " max)
	       (debug-print "action      : " action)
	       (define (trap-context-position* position*)
(print "pos*: " position*)
		  (for-each trap-context-une-position position*) )
	       (define (trap-context-une-position p)
		  (let ( (a (vector-ref position p)) )
		     (debug-print "trap-une-p: " p " (" a ")")
		     (cond
		      ((number? a)
		       (trap-action 'etat action context))
		      ((trivial? p)
		       (trap-transition (vector-ref trivial p) a context))
		      (else
		       (trap-context-position* (follow-in-min-max min max p)) ) ) ) )
	       (trap-context-position* (node-firstpos node)) ) )
;*---- trap -----------------------------------------------------------*/
(debug-print "traping...")
(debug-print "trivial: " trivial)
(when debug (read-char))
	 (for-each (lambda (t)
		      (case (car t)
			 ((context)
			  (trap-context (cadr t) (caddr t)))
			 (else
			  (wrong "trap unknown" (car t)))) )
		   l-trap) ) )

'trap-not-used

;*---------------------------------------------------------------------*/
;*    /home/serrano/read-rp/wc.scm ...                                 */
;*                                                                     */
;*    Auteur      :  Manuel SERRANO                                    */
;*    Creation    :  Fri May  3 09:44:24 1991                          */
;*    Last change :  Fri May  3 10:20:43 1991  (serrano)               */
;*                                                                     */
;*    La gammaire 'word-count'                                         */
;*---------------------------------------------------------------------*/

(define char 0)
(define line 0)
(define word 0)

(define wc (regular-grammar ()
   ((+ #\Newline) 
    (set! char (+ char (the-length)))
    (set! line (+ line (the-length)))
    (ignore))
   ((+ #\space)
    (set! word (1+ word))
    (set! char (+ char (the-length)))
    (ignore))
   ((+ (<-> #\Newline #\space))
    (set! char (+ char (the-length)))
    (ignore)) ) )

(use-regular-parser wc)

(define (lire)
   (define st (make-stream/rp 1024 "toto.rp"))
   (set! t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (while (not (stream/rp-eof? st))
	     (stream/rp-read! st))
         (set! t1 (runtime)))
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))

(define (count)
   (define st (make-stream/rp 1024 "toto.rp"))
   (use-stream st)
   (set! char 0)
   (set! line 0)
   (set! word 0)
   (define t0 'dummy)
   (define t1 'dummy)
   (begin
      (set! t0 (runtime))
      (read/rp)
      (set! t1 (runtime)))
   (print line "  " word "  " char)
   (print "time: " (- t1 t0) "s    (soit " (/ char (- t1 t0)) 
	         " char/s)") 
   (stream/rp-close st))
		   

