;*---------------------------------------------------------------------*/ ;* Copyright (c) 1997 by Manuel Serrano. All rights reserved. */ ;* */ ;* ,--^, */ ;* _ ___/ /|/ */ ;* ,;'( )__, ) ' */ ;* ;; // L__. */ ;* ' \ / ' */ ;* ^ ^ */ ;* */ ;* */ ;* This program is distributed in the hope that it will be useful. */ ;* Use and copying of this software and preparation of derivative */ ;* works based upon this software are permitted, so long as the */ ;* following conditions are met: */ ;* o credit to the authors is acknowledged following */ ;* current academic behaviour */ ;* o no fees or compensation are charged for use, copies, */ ;* or access to this software */ ;* o this copyright notice is included intact. */ ;* This software is made available AS IS, and no warranty is made */ ;* about the software or its performance. */ ;* */ ;* Bug descriptions, use reports, comments or suggestions are */ ;* welcome Send them to */ ;* Manuel Serrano -- Manuel.Serrano@cui.unige.ch */ ;*---------------------------------------------------------------------*/ ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/runtime1.8/Match/compiler.scm */ ;* */ ;* Author : Jean-Marie Geffroy */ ;* Creation : Thu Jan 14 10:29:50 1993 */ ;* Last change : Mon Jul 10 14:28:12 1995 (serrano) */ ;* */ ;*---------------------------------------------------------------------*/ ;* A hand-written pattern "compiler" */ ;*---------------------------------------------------------------------*/ ;* References: */ ;* [1] C.Queinnec & J.M. Geffroy, "Pattern matching in Scheme" */ ;* ( tech. report ) */ ;* [2] C.Queinnec & J.M. Geffroy, "Partial Evaluation applied to */ ;* Symbolic Pattern Matching with intelligent backtrack" */ ;* (Workshop on Static Analysis, 92, Bordeaux) */ ;*---------------------------------------------------------------------*/ ;*---------------------------------------------------------------------*/ ;* Important: we deliberately choosed to allow "non-linear patterns"*/ ;* (in which variables may appear more than once). We test */ ;* the equality between subparts of the datum trough the EQ? */ ;* predicate. */ ;*---------------------------------------------------------------------*/ (module __match_compiler (export (pcompile f)) (import (__error "Llib/error.scm") (__match_s2cfun "Match/s2cfun.scm") (__match_descriptions "Match/descr.scm")) (use (__type "Llib/type.scm") (__bigloo "Llib/bigloo.scm") (__tvector "Llib/tvector.scm") (__structure "Llib/struct.scm") (__tvector "Llib/tvector.scm") (__rgc "Rgc/runtime.scm") (__r4_numbers_6_5 "Ieee/number.scm") (__r4_numbers_6_5_fixnum "Ieee/fixnum.scm") (__r4_numbers_6_5_flonum "Ieee/flonum.scm") (__r4_characters_6_6 "Ieee/char.scm") (__r4_equivalence_6_2 "Ieee/equiv.scm") (__r4_booleans_6_1 "Ieee/boolean.scm") (__r4_symbols_6_4 "Ieee/symbol.scm") (__r4_strings_6_7 "Ieee/string.scm") (__r4_pairs_and_lists_6_3 "Ieee/pair-list.scm") (__r4_input_6_10_2 "Ieee/input.scm") (__r4_control_features_6_9 "Ieee/control.scm") (__r4_vectors_6_8 "Ieee/vector.scm") (__r4_ports_6_10_1 "Ieee/port.scm") (__r4_output_6_10_3 "Ieee/output.scm") (__evenv "Eval/evenv.scm"))) (define (pcompile f) (let ((s (jim-gensym "E-"))) `(lambda (,s) ,(compile f s r.init m.init k.init z.init d.init)))) (define (compile f e r m k z d) (cond [(more-precise? d f) (k r z d)] [(compatible? d f) (case (car f) ((any) (compile-any e r m k z d)) ((check) (compile-check (cadr f) e r m k z d)) ((quote) (compile-quote f e r m k z d)) ((var) (compile-var (cadr f) e r m k z d)) ((not) (compile-not (cadr f) e r m k z d)) ((or) (compile-or (cadr f) (caddr f) e r m k z d)) ((tagged-or)(compile-tagged-or (cadr f) (caddr f) (cadddr f) e r m k z d)) ((and) (compile-and (cadr f) (caddr f) e r m k z d)) ((cons) (compile-cons (cadr f) (caddr f) e r m k z d)) ((times) (compile-times (cadr f) (caddr f) (cadddr f) e r m k z d)) ((tree) (compile-tree (cadr f) (caddr f) (cadddr f) e r m k z d)) ((hole) (compile-hole (cadr f) e r m k z d)) ;; Extension to vectors... ((vector-begin) (compile-vector-begin (cadr f) (caddr f) e r m k z d)) ((vector-end) (compile-vector-end e r m k z d)) ((vector-any) (compile-vector-any e r m k z d)) ((vector-cons) (compile-vector-cons (cadr f) (caddr f) e r m k z d)) ((vector-times) (compile-vector-times (cadr f) (caddr f) (cadddr f) e r m k z d)) ;STk ((struct-pat) (compile-struct-pat f e r m k z d)) (else (wrong "Unrecognized pattern" f)))] [#t (z d) ] )) (define (compile-any e r m k z d) (k r z d)) ;*---------------------------------------------------------------------*/ ;* check doesn't allow to extend the description since we do not */ ;* restrict the predicates that can be used. */ ;*---------------------------------------------------------------------*/ (define (compile-check p e r m k z d) `(if (,p ,e) ,(k r z d) ,(z d))) (define (compile-quote f e r m k z d) (build-if `(eq? ,e (quote ,(cadr f))) (k r z `(quote ,(cadr f))) (z (pattern-minus d f)))) (define (compile-not f e r m k z d) (compile f e r m (lambda (r2 z2 d2) (z d2)) (lambda (d2) (k r z d2)) d) ) ;*---------------------------------------------------------------------*/ ;* Both branches of an or pattern must contain the same variables */ ;*---------------------------------------------------------------------*/ (define (compile-or f1 f2 e r m k z d) (let* ((*k* (jim-gensym "KAP-")) (*vars* (pattern-variables f1)) (*call* `(,*k* ,@*vars*)) (success-form (k (extend* r *vars*) z d))) (if (or (eq? success-form #f) (equal? (cdr *call*) (cdr success-form)) (isDirectCall? success-form)) (compile f1 e r m (lambda (r z d) success-form) (lambda (d) (compile f2 e r m (lambda (r z d) success-form) z d) ) d) (let ((res (compile f1 e r m (lambda (r z d) *call*) (lambda (d) (compile f2 e r m (lambda (r z d) *call*) z d) ) d))) (if res `(labels ((,*k* ,*vars* ,success-form)) ,res) res) ) ) ) ) ;*---------------------------------------------------------------------*/ ;* We try to avoid (labels ((g (x) (f x))) ...) */ ;*---------------------------------------------------------------------*/ (define (isDirectCall? e) (and (pair? e) (let ((pr (car e))) (and (symbol? e) (let ((s (symbol->string pr))) (and (>fx (string-length s) 3) (let ((s (substring s 0 3))) (or (string=? s "KAP") (string=? s "TAG"))))))))) ;*---------------------------------------------------------------------*/ ;* Branches of a tagged-or do not need to contain the same vars */ ;*---------------------------------------------------------------------*/ (define (compile-tagged-or f1 t1 f2 e r m k z d) (let ((*vars* (pattern-variables f1))) (compile f1 e r m (lambda (r z c) `(,t1 ,@*vars*)) (lambda (d) (compile f2 e r m k z d) ) d))) (define (compile-and f1 f2 e r m k z c) (if (compatible? f1 f2) (compile f1 e r m (lambda (r2 z2 c2) (compile f2 e r2 m k z2 c2 ) ) z c ) (z c) ) ) ;*---------------------------------------------------------------------*/ ;* Non linear patterns */ ;*---------------------------------------------------------------------*/ (define (compile-var n e r m k z c) (if (boundp n r) (build-if `(eq? ,n ,e) (k r z (pattern-plus c (list 'var n))) (z (pattern-minus c (list 'var n))) ) (let ((body (k (extend-alist r n e) z (pattern-plus c (list 'var n))))) (if (> (count-occurrences n body 0) 1) `(let ((,n ,e)) ,body) (unfold n e body) ) ) ) ) (define (count-occurrences s e acc) (if (null? e) acc (if (atom? e) (if (eq? s e) (+ acc 1) acc) (if (pair? e) (if (eq? (car e) 'quote) acc (+ (count-occurrences s (car e) acc) (count-occurrences s (cdr e) acc)) ) ) ) ) ) (define-inline (caddddr x) (cadr (cdddr x))) ;*---------------------------------------------------------------------*/ ;* La version suivante de cons ne permet pas de compiler */ ;* correctement les filtres tree: elle engendre un code tail-rec */ ;*---------------------------------------------------------------------*/ (define (compile-cons f1 f2 e r m k z c) (if (isCons? c) (succes-cons f1 f2 e r m k z c) `(if (pair? ,e) ,(succes-cons f1 f2 e r m k z c) ,(z (pattern-minus c (list 'cons '(any) '(any))))))) (define (succes-cons f1 f2 e r m k z c) (let* ((*car* (jim-gensym "CAR-")) (*cdr* (jim-gensym "CDR-")) (body (compile f1 *car* r m (lambda (r2 z2 c2) (compile f2 *cdr* r2 m (lambda (r3 z3 c3) (k r3 z3 (list 'cons c2 c3) ) ) (lambda (c3) (z (list 'cons c2 c3))) (pattern-cdr c)) ) (lambda (c2) (z (list 'cons c2 (pattern-cdr c)))) (pattern-car c) ) ) ) (build-let *car* *cdr* e body) ) ) ;* (body (compile */ ;* f1 `(car ,e) r m */ ;* (lambda (r2 z2 c2) */ ;* (compile f2 `(cdr ,e) r2 m */ ;* (lambda (r3 z3 c3) */ ;* (k r3 z3 (list 'cons c2 c3) ) ) */ ;* (lambda (c3) (z (list 'cons c2 c3))) */ ;* (pattern-cdr c)) ) */ ;* (lambda (c2) (z (list 'cons c2 (pattern-cdr c)))) */ ;* (pattern-car c) ) ) */ ;* ) */ ;* body)) */ ;*---------------------------------------------------------------------*/ ;* Instanciate-try may be re-written in order to avoid generating */ ;* more than X specialized versions of a recursive pattern: we just */ ;* have to generate a "generic' version of the TIMES pattern, with a */ ;* (any) description, and to update a counter of instances. */ ;*---------------------------------------------------------------------*/ ;*---------------------------------------------------------------------*/ ;* In order to compile recursive patterns of the form */ ;* (tree L (cons (hole L) (hole L)) ) */ ;* we should differenciate the occurrences of HOLE, and give them */ ;* distinct continuations. */ ;*---------------------------------------------------------------------*/ (define (compile-times n f1 f2 e r m k0 z0 d0) (let ((F-Env '()) (D-env '())) (letrec ((instanciate-try (lambda (r m k z d) (let ((tmp (look-for-descr d D-env))) (if tmp (cadr tmp) (let ((g (jim-gensym "G-")) (try (jim-gensym "TRY-"))) (set! D-env (cons (list d try) D-env)) (let ((new-def (list try `(letrec ((,try (lambda (,g) ,(compile f2 g r m k (lambda (d2) (compile f1 g r (extend m n instanciate-try) k z d2) ) ;;; '(any) d) ) ) ) ) ) ) ) (set! F-env (cons new-def F-env) ) try) ) ) ) ) ) ) (let ((res-body (instanciate-try r m (lambda (r z d) (k0 r z d0)) (lambda (d) (z0 d0)) d0))) `(letrec ,(map caadadr F-env) (,res-body ,e) ) ) ) ) ) (define (compile-hole n e r m k z d) `(,((m n) r m k z d) ,e) ) (define (compile-tree n f1 f2 e r m k0 z0 d0) (wrong "Tree not yet allowed")) ;*---------------------------------------------------------------------*/ ;* Extension to vectors */ ;*---------------------------------------------------------------------*/ ;*---------------------------------------------------------------------*/ ;* Description: (vector lg [d1 d2 ...dlg]) or (not (vector)) */ ;*---------------------------------------------------------------------*/ (define (compile-vector-begin lgmin f e r m k z d) (if (isVector? d) (if (>= (cadr d) lgmin) ((compile f e r m k z d) 0) `(if (>= (vector-length ,e) ,lgmin) ,((compile f e r m k z d) 0) ,(z d))) `(if (vector? ,e) (if (>= (vector-length ,e) ,lgmin) ,((compile f e r m k z `(vector ,lgmin ,(make-vector lgmin '(any))) ) 0) ,(z `(vector 0 ,(make-vector 0 '(any))))) ,(z (pattern-plus d '(not (vector))))))) ;*---------------------------------------------------------------------*/ ;* We know that the datum is a vector of the desired minimal */ ;* length, and the descr. is (vector ...) */ ;*---------------------------------------------------------------------*/ (define (compile-vector-cons f1 f2 e r m k z d) (lambda (i) (if (>= i (vector-length (caddr d))) (set-car! (cddr d) (extend-vector (caddr d) (+ i 1) '(any))) #t) (compile f1 `(vector-ref ,e ,i) r m (lambda (r z1 d1) ((compile f2 e r m k z (vector-plus d i d1)) (+ i 1))) (lambda (d1) (z (vector-plus d i d1))) (vector-ref (caddr d) i)))) (define (compile-vector-end e r m k z d) (lambda (i) (build-if `(eq? ,i (vector-length ,e)) (k r z d) (z d)))) (define (compile-vector-any e r m k z d) (lambda (i) (k r z d))) (define (compile-vector-times n f1 f2 e r m k0 z0 d0) (wrong "Not yet allowed")) ;*---------------------------------------------------------------------*/ ;* Pattern matching on structures */ ;*---------------------------------------------------------------------*/ #|STk (define (compile-struct-pat f e r m k z d) (let* ((nom (cadr f)) (p* (cddr f)) (*k* (jim-gensym "KAP-")) (*vars* (pattern-variables f)) (*call* `(,*k* ,@*vars*)) (success-form (k (extend* r *vars*) z d)) (failure-form (z d)) (indexes (integers 0 (- (length p*) 1)))) (build-if `(,(string->symbol (string-append (symbol->string nom) "?")) ,e) (compile* p* indexes e r m (lambda (r z d) success-form) (lambda (d) failure-form) '(any)) failure-form))) (define (compile* p* i* e r m k z d) (if (null? p*) (k r z d) (compile (car p*) `(struct-ref ,e ,(car i*)) r m (lambda (rr zz dd) (compile* (cdr p*) (cdr i*) e rr m k z '(any))) z '(any)))) |# ;*---------------------------------------------------------------------*/ (define (look-for-descr d D-env) (if (null? D-env) #f (if (equal? (caar D-env) d) (car D-env) (look-for-descr d (cdr D-env))))) (define (k.init r z d) #t) (define (z.init d) #f) (define d.init '(any)) ;*---------------------------------------------------------------------*/ ;* We do not need anything better... */ ;*---------------------------------------------------------------------*/ (define r.init '()) (define (extend-alist l pt im) `((,pt . ,im) ,@l)) (define (alistlookup env pt) (if (assq pt env) (cdr (assq pt env)) 'unbound)) (define (extend* r v*) (if (null? v*) r (extend-alist (extend* r (cdr v*)) (car v*) 'dummy))) (define (m.init n) (lambda (e r k z c) (wrong "No current repetition named" n) ) ) (define (boundp pt env) (not (eqv? (alistlookup env pt) 'unbound))) ;*---------------------------------------------------------------------*/ ;* Miscellaneous */ ;*---------------------------------------------------------------------*/ (define (wrong . args) (error "Incorrect pattern: " args " *** ")) (define (caadadr x) (car (cadadr x))) (define (extend fn pt im) (lambda (x) (if (eq? x pt) im (fn x)))) (define (build-if tst then else) (cond ((eq? tst #t) then) ((eq? tst #f) else) ((and (eq? then #t) (eq? else #f)) tst) ((and (eq? then #f) (eq? else #t)) `(not ,tst)) (else `(if ,tst ,then ,else)))) (define (build-let *car* *cdr* e body) (if (> (count-occurrences *car* body 0) 1) (if (> (count-occurrences *cdr* body 0) 1) `(let ((,*car* (car ,e)) (,*cdr* (cdr ,e))) ,body ) `(let ((,*car* (car ,e))) ,(unfold *cdr* `(cdr ,e) body ))) (if (> (count-occurrences *cdr* body 0) 1) `(let ((,*cdr* (cdr ,e))) ,(unfold *car* `(car ,e) body) ) (unfold *cdr* `(cdr ,e) (unfold *car* `(car ,e) body ) ) ) ) ) ;*---------------------------------------------------------------------*/ ;* (unfold s v e) replaces s by v in e */ ;*---------------------------------------------------------------------*/ (define (unfold s v e) (if (null? e) '() (if (atom? e) (if (eq? e s) v e) (if (pair? e) (if (eq? (car e) 'quote) e (let ((f (car e)) (args (cdr e))) `(,(unfold s v f) . ,(unfold s v args) ) ) ) ) ) ) ) (define (integers from to) (if (> from to) '() (cons from (integers (+ from 1) to))))