;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Rgc/rgcexpand.scm            */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Wed Sep  9 09:21:29 1998                          */
;*    Last change :  Fri Oct 31 16:06:28 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    The expanders that implements the RGC user forms.                */
;*    -------------------------------------------------------------    */
;*    This module implements the expanders for:                        */
;*       - regular-grammar                                             */
;*       - string-case                                                 */
;*    -------------------------------------------------------------    */
;*    Source documentation:                                            */
;*       @path ../../manuals/rgc.texi@                                 */
;*       @node Regular Parsing@                                        */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __rgc_expand

   (import  __rgc_rules
	    __rgc_tree
	    __rgc_dfa
	    __rgc_compile
	    __rgc_config
	    __rgc
	    __rgc_set
	    __error)

   (use     __type
	    __bigloo
	    __tvector
	    __structure
	    
	    __r4_numbers_6_5
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_pairs_and_lists_6_3
	    __r4_input_6_10_2
	    __r4_control_features_6_9
	    __r5_control_features_6_4
	    __r4_ports_6_10_1
	    __r4_output_6_10_3
	    __r4_vectors_6_8)

   (export  (expand-string-case x e)
	    (expand-regular-grammar x e)))

;*---------------------------------------------------------------------*/
;*    expand-string-case ...                                           */
;*    -------------------------------------------------------------    */
;*    This function expands the @deffn string-case@ form               */
;*    -------------------------------------------------------------    */
;*    This expander expands form like:                                 */
;*       (string-case s                                                */
;*          (("toto") 'match1)                                         */
;*          ((+ (in "abcde")) 'match2)                                 */
;*          (else 'else))                                              */
;*---------------------------------------------------------------------*/
(define (expand-string-case x e)
   (match-case x
      ((?- ?str . ?clauses)
       (let ((port-id (gensym 'port)))
	  (let ((new `(let ((,port-id (open-input-string ,str)))
			 (unwind-protect
			    (read/rp (regular-grammar ()
					,@clauses)
				     ,port-id)
			    (close-input-port ,port-id)))))
	     (set-car! x (car new))
	     (set-cdr! x (cdr new))
	     (e x e))))
      (else
       (error "string-case" "Illegal form" x))))

;*---------------------------------------------------------------------*/
;*    expand-regular-grammar ...                                       */
;*    -------------------------------------------------------------    */
;*    This function expands the @deffn regular-grammar@ form           */
;*---------------------------------------------------------------------*/
(define (expand-regular-grammar x e)
   (match-case x
      ((?- ?user-env . ?clauses)
       (multiple-value-bind (tree actions else-num submatch?)
	  ;; we normalize the grammar. that is we build one uniq
	  ;; regular expression from the grammar
	  (rules->regular-tree user-env clauses)
	  (multiple-value-bind (node followpos positions submatches)
	     ;; we build the tree, that is we translate a list into
	     ;; a data structure that suits the algorithm for building
	     ;; the dfa
	     (regular-tree->node tree)
;* 	     (print "node: " node)                                     */
;* 	     (print "followpos: " (map rgcset->list (vector->list followpos))) */
;* 	     (print "positions: " positions)                           */
;* 	     (print "positions(ascii): "                               */
;* 		    (map (lambda (x)                                   */
;* 			    (if (< x 255)                              */
;* 				(let ((c (integer->char x)))           */
;* 				   (if (or (char-alphabetic? c)        */
;* 					   (char-numeric? c))          */
;* 				       c                               */
;* 				       x))))                           */
;* 			 (vector->list positions)))                    */
;* 	     (print "submatches: " submatches)                         */
	     ;; We now build the dfa transitions.
	     (begin
		(let* ((dfa (node->dfa node followpos positions))
		       (sexp (make-regular-parser (compile-dfa submatches
							       dfa
							       positions)
						  actions
						  else-num
						  submatch?)))
		   (reset-special-match-char!)
		   (reset-tree!)
		   (reset-dfa!)
		   (e sexp e))))))
      (else
       (error "regular-grammar" "Illegal form" x))))

;*---------------------------------------------------------------------*/
;*    make-regular-parser ...                                          */
;*---------------------------------------------------------------------*/
(define (make-regular-parser states actions else-num submatch?)
   `(let ((the-rgc-context #unspecified))
       (lambda (input-port proc)
	  ;; compiled states
	  ,@states
 	  ;; rgc library functions
	  ;; @deffn the-port@
	  (define (the-port::input-port)
	     input-port)
	  ;; @deffn the-character@
	  (define (the-character::char)
	     (rgc-buffer-character input-port))
	  ;; @deffn the-string@
	  (define (the-string::bstring)
	     (rgc-buffer-substring input-port 0 (the-length)))
	  ;; @deffn the-substring@
	  (define (the-substring::bstring min max)
	     (if (and (>=fx min 0) (<=fx max (the-length)) (>=fx max min))
		 (rgc-buffer-substring input-port min max)
		 (error "the-substring" "Illegal range" (cons min max))))
	  ;; @deffn the-length@
	  (define (the-length::int)
	     (rgc-buffer-length input-port))
	  ;; @deffn the-fixnum@
	  (define (the-fixnum::long)
	     (rgc-buffer-fixnum input-port))
	  ;; @deffn the-integer@
	  (define (the-integer::obj)
	     (rgc-buffer-integer input-port))
	  ;; @deffn the-flonum@
	  (define (the-flonum::double)
	     (rgc-buffer-flonum input-port))
	  ;; @deffn the-symbol@
	  (define (the-symbol::symbol)
	     (rgc-buffer-symbol input-port))
	  ;; @deffn the-keyword@
	  (define (the-keyword::keyword)
	     (rgc-buffer-keyword input-port))
	  ;; @deffn the-failure@
	  (define (the-failure)
	     (if (=fx (the-length) 0)
		 ;; this is the end-of-file object
		 #<0100>
		 (string-ref (the-string) 0)))
	  ;; @deffn the-context@
	  (define (the-context)
	     the-rgc-context)
	  ;; @deffn rgc-context?@
	  (define (rgc-context?::bool context)
	     (eq? the-rgc-context context))
	  ;; @deffn rgc-context@
	  (define (rgc-set-context! context)
	     (set! the-rgc-context context))
	  (define (rgc-context . context)
	     (if (pair? context)
		 (set! the-rgc-context (car context))
		 (set! the-rgc-context #unspecified)))
	  ,@(if submatch?
		(list
		 '(define rgc-submatches (quote ()))
		 '(define (rgc-submatch-start! match::int submatch::int)
;*  		     (print "start match: " match " submatch: " submatch */
;* 			    " pos: " (rgc-buffer-position input-port)) */
		     (set! rgc-submatches
			   (cons (vector match
					 submatch
					 (rgc-buffer-position input-port)
					 (quote start))
				 rgc-submatches)))
		 '(define (rgc-submatch-start*! match::int submatch::int)
;* 		     (print "start* match: " match " submatch: " submatch */
;* 			    " pos: " (rgc-buffer-position input-port)) */
		     (set! rgc-submatches
			   (cons (vector match
					 submatch
					 (rgc-buffer-position input-port)
					 (quote start*))
				 rgc-submatches)))
		 '(define (rgc-submatch-stop! match::int submatch::int)
;* 		     (print "stop match: " match " submatch: " submatch */
;* 			    " pos: " (rgc-buffer-position input-port)) */
		     (set! rgc-submatches
			   (cons (vector match
					 submatch
					 (rgc-buffer-position input-port)
					 (quote stop))
				 rgc-submatches))))
		'())
	  ;; main function
	  (define (ignore)
	     (rgc-start-match! input-port)
	     ,@(if submatch?
		   (list '(set! rgc-submatches (quote ())))
		   '())
	     (let ((match::long (if (procedure? proc)
				    (proc ,(state-name (get-initial-state))
					  input-port
					  ,else-num
					  the-rgc-context)
				    (,(state-name (get-initial-state))
				     input-port
				     ,else-num
				     the-rgc-context))))
		(rgc-set-filepos! input-port)
		,@(if submatch?
		      ;; @deffn the-submatch@
		      '((define (the-submatch num)
			   (if (=fx num 0)
			       (the-string)
			       (multiple-value-bind (start stop)
				  (rgc-the-submatch rgc-submatches
						    (rgc-buffer-position
						     input-port)
						    match
						    num)
				  (if (and (>=fx start 0) (>=fx stop start))
				      (the-substring start stop)
				      "")))))
		      '())
		(case match
		   ,@(let loop ((actions actions)
				(num     0)
				(res     '()))
			(if (null? actions)
			    res
			    (loop (cdr actions)
				  (+fx num 1)
				  (cons `((,num) ,(car actions)) res))))
		   (else
		    (error "regular-grammar" "Illegal match" match)))))
	  ;; we start parsing. See the module __rgc for the definition
	  ;; of the unsafe-rgc variable (@ref rgc.scm:unsafe-rgc@)
	  ;; @label unsafe-rgc@
	  ,(if *unsafe-rgc*
	       '(ignore)
	       '(if (closed-input-port? (the-port))
		    (error "regular-grammar"
			   "Can't read on a closed input port"
			   (the-port))
		    (ignore))))))
		    
