1.1 --- a/etng-r2/compile-to-scheme.scm	Fri Jul 24 16:00:30 2009 +0100
     1.2 +++ b/etng-r2/compile-to-scheme.scm	Sat Oct 08 15:36:03 2011 -0400
     1.3 @@ -1,12 +1,10 @@
     1.4  (define previous-inspector (current-inspector))
     1.5  (current-inspector (make-inspector))
     1.6  
     1.7 -(define-record-type etng-function
     1.8 -  (make-etng-function ;;sources
     1.9 -		      clauses)
    1.10 -  etng-function?
    1.11 -  ;;(sources etng-function-sources)
    1.12 -  (clauses etng-function-clauses))
    1.13 +(define-record-type etng-alternation
    1.14 +  (make-etng-alternation clauses)
    1.15 +  etng-alternation?
    1.16 +  (clauses etng-alternation-clauses))
    1.17  
    1.18  (current-inspector previous-inspector)
    1.19  
    1.20 @@ -49,28 +47,77 @@
    1.21  	      (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
    1.22  	      message))
    1.23  
    1.24 -(define (etng-lookup receiver via message)
    1.25 -  (let lookup ((clauses (etng-function-clauses via)))
    1.26 -    (if (null? clauses)
    1.27 -	#f
    1.28 -	(let apply-loop ((matcher (car clauses))
    1.29 -			 (args message))
    1.30 -	  (if (null? args)
    1.31 -	      (make-etng-function ;;... some source code ...?
    1.32 -	       (list matcher
    1.33 -		     (lambda (arg kcomplete kmore kfail)
    1.34 -		       (
    1.35 -	      (let ((arg (car args))
    1.36 -		    (remaining-args (cdr args)))
    1.37 -		(matcher arg
    1.38 -			 (lambda (thunk) thunk)
    1.39 -			 (lambda (next-matcher) (apply-loop next-matcher remaining-args))
    1.40 -			 (lambda () (lookup (cdr clauses)))))))
    1.41 +(define (etng-alternation->parser a)
    1.42 +  (lambda (input ks kf)
    1.43 +    (let loop ((clauses (etng-alternation-clauses a)))
    1.44 +      (if (null? clauses)
    1.45 +	  (kf)
    1.46 +	  ((car clauses) input ks (lambda () (loop (cdr clauses))))))))
    1.47 +
    1.48 +(define (make-parser-invocation first-message)
    1.49 +  (let ((fragments-rev (make-parameter (list first-message))))
    1.50 +    (define (fragment-following f)
    1.51 +      (let search ((candidate #f)
    1.52 +		   (fs (fragments-rev)))
    1.53 +	(cond
    1.54 +	 ((null? fs) (error 'should-not-reach-here 'fragment-following))
    1.55 +	 ((eq? (car fs) f) candidate)
    1.56 +	 (else (search (car fs) (cdr fs))))))
    1.57 +    (define (remaining-input-following f)
    1.58 +      (let search ((acc '())
    1.59 +		   (fs (fragments-rev)))
    1.60 +	(cond
    1.61 +	 ((null? fs) (error 'should-not-reach-here 'fragment-following))
    1.62 +	 ((eq? (car fs) f) acc)
    1.63 +	 (else (search (append (car fs) acc) (cdr fs))))))
    1.64 +    (define (stream-fragment f)
    1.65 +      (let loop ((position f))
    1.66 +	(lambda (op k)
    1.67 +	  (case op
    1.68 +	    ((next)
    1.69 +	     (if (null? position)
    1.70 +		 (let ((next-fragment (fragment-following f)))
    1.71 +		   (if next-fragment
    1.72 +		       ((stream-fragment next-fragment) 'next k)
    1.73 +		       (let ((so-far (fragments-rev)))
    1.74 +			 (lambda (ignored-receiver)
    1.75 +			   (lambda (message)
    1.76 +			     (parameterize ((fragments-rev (cons message so-far)))
    1.77 +			       ((stream-fragment message) 'next k)))))))
    1.78 +		 (k (car position) (loop (cdr position)))))
    1.79 +	    ((rest)
    1.80 +	     (k (append position (remaining-input-following f))))
    1.81 +	    (else
    1.82 +	     (error 'invalid-op op))))))
    1.83 +    (stream-fragment first-message)))
    1.84 +
    1.85 +(define (etng-lookup via message)
    1.86 +  (cond
    1.87 +   ((etng-alternation? via)
    1.88 +    ((etng-alternation->parser via)
    1.89 +     (make-parser-invocation message)
    1.90 +     (lambda (rhs-thunk-waiting-for-self remaining-input)
    1.91 +       (remaining-input 'rest
    1.92 +			(lambda (remaining-message)
    1.93 +			  (if (null? remaining-message)
    1.94 +			      rhs-thunk-waiting-for-self
    1.95 +			      (lambda (receiver)
    1.96 +				(etng-send (rhs-thunk-waiting-for-self receiver)
    1.97 +					   remaining-message))))))
    1.98 +     (lambda () #f)))
    1.99 +   ((procedure? via)
   1.100 +    (via message))
   1.101 +   (else 'invalid-via (list via message))))
   1.102 +
   1.103 +(define (etng-directly-invokable? x)
   1.104 +  (or (procedure? x) ;; a parser-invocation, (lambda (message) ...)
   1.105 +      (etng-alternation? x) ;; a parser without invocation: see etng-lookup
   1.106 +      ))
   1.107  
   1.108  (define (etng-send* receiver via message)
   1.109    (cond
   1.110 -   ((etng-function? via)
   1.111 -    (let ((thunk (or (etng-lookup receiver via message)
   1.112 +   ((etng-directly-invokable? via)
   1.113 +    (let ((thunk (or (etng-lookup via message)
   1.114  		     (error 'does-not-understand receiver via message))))
   1.115        (thunk receiver)))
   1.116     ((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
   1.117 @@ -85,8 +132,7 @@
   1.118    (etng-send* receiver receiver message))
   1.119  
   1.120  (define (etng-merge-functions f1 f2)
   1.121 -  (make-etng-function ;;(append (etng-function-sources f1) (etng-function-sources f2))
   1.122 -		      (append (etng-function-clauses f1) (etng-function-clauses f2))))
   1.123 +  (make-etng-alternation (append (etng-alternation-clauses f1) (etng-alternation-clauses f2))))
   1.124  
   1.125  (define (compile-to-scheme ast)
   1.126  
   1.127 @@ -112,10 +158,8 @@
   1.128      (case (car ast)
   1.129        ((ref) (mangle-etng-id (cadr ast)))
   1.130        ((lit) `',(cadr ast))
   1.131 -      ((object) `(make-etng-function ;;',(cddr ast)
   1.132 -				     (list ,@(map (method (cadr ast)) (cddr ast)))))
   1.133 -      ((function) `(make-etng-function ;;',(cdr ast)
   1.134 -				       (list ,@(map (method #f) (cdr ast)))))
   1.135 +      ((object) `(make-etng-alternation (list ,@(map (method (cadr ast)) (cddr ast)))))
   1.136 +      ((function) `(make-etng-alternation (list ,@(map (method #f) (cdr ast)))))
   1.137        ((tuple) `(vector ,@(map expr (cdr ast))))
   1.138        ((send) `(etng-send ,(expr (cadr ast)) (list ,@(map expr (cddr ast)))))
   1.139        ((assemble) `(let ,(map (lambda (binding)
   1.140 @@ -146,15 +190,20 @@
   1.141  
   1.142    (define (method self-id)
   1.143      (lambda (ast)
   1.144 -      `(lambda (_arg _kcomplete _kmore _kfail)
   1.145 -	 ,(let* ((patterns (cadr ast))
   1.146 -		 (body (caddr ast))
   1.147 -		 (remaining-patterns (cdr patterns)))
   1.148 -	    (pattern (car patterns)
   1.149 -		     (if (null? remaining-patterns)
   1.150 -			 `(_kcomplete (lambda (,(if self-id (mangle-etng-id self-id) '_self))
   1.151 -					,(expr body)))
   1.152 -			 `(_kmore ,((method #f) `(method ,remaining-patterns ,body))))
   1.153 -		     `(_kfail))))))
   1.154 +      (let ((body (caddr ast)))
   1.155 +	`(lambda (_stream _kt _kf)
   1.156 +	   ,(let loop ((patterns (cadr ast)))
   1.157 +	      `(_stream 'next
   1.158 +			(lambda (_arg _stream)
   1.159 +			  ,(let* ((remaining-patterns (cdr patterns)))
   1.160 +			     (pattern (car patterns)
   1.161 +				      (if (null? remaining-patterns)
   1.162 +					  `(_kt (lambda (,(if self-id
   1.163 +							      (mangle-etng-id self-id)
   1.164 +							      '_self))
   1.165 +						  ,(expr body))
   1.166 +						_stream)
   1.167 +					  (loop remaining-patterns))
   1.168 +				      `(_kf))))))))))
   1.169  
   1.170    (toplevel ast))