609 lines
22 KiB
Scheme
609 lines
22 KiB
Scheme
|
;*---------------------------------------------------------------------*/
|
||
|
|
;* 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 */
|
||
|
|
;*---------------------------------------------------------------------*/
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; geffroy/Match3.0/descriptions.scm ... */
|
||
|
|
;;; Author : Jean-Marie Geffroy */
|
||
|
|
;;; Ecole Polytechnique & INRIA Rocquencourt */
|
||
|
|
;;; E-mail : geffroy@inria.fr */
|
||
|
|
;;; Last change : Tue Jun 8 13:58:06 1993 (geffroy) */
|
||
|
|
;;; */
|
||
|
|
;;; Les fonctions de manipulation des descriptions et */
|
||
|
|
;;; filtres */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
(module __match_descriptions
|
||
|
|
|
||
|
|
(export (pattern-variables f)
|
||
|
|
(pattern-car p)
|
||
|
|
(pattern-cdr p)
|
||
|
|
(pattern-plus p1 p2)
|
||
|
|
(pattern-minus p1 p2)
|
||
|
|
(vector-plus v i d)
|
||
|
|
(vector-minus v i d)
|
||
|
|
(compatible? p d)
|
||
|
|
(more-precise? d p)
|
||
|
|
(extend-vector v lg fill)
|
||
|
|
(inline isAny? c)
|
||
|
|
(inline isCheck? c)
|
||
|
|
(inline isSuccess? c)
|
||
|
|
(inline isTop? c)
|
||
|
|
(inline isBottom? c)
|
||
|
|
(inline isQuote? c)
|
||
|
|
(inline isVar? c)
|
||
|
|
(inline isNot? c)
|
||
|
|
(inline isAnd? c)
|
||
|
|
(inline isOr? c)
|
||
|
|
(inline isT-Or? c)
|
||
|
|
(inline isTagged-Or? c)
|
||
|
|
(inline isCons? c)
|
||
|
|
(inline isACons? c)
|
||
|
|
(inline isXCons? c)
|
||
|
|
(inline isTimes? c)
|
||
|
|
(inline containsHole? c)
|
||
|
|
(inline isHole? c)
|
||
|
|
(inline isVector? c)
|
||
|
|
(inline isVector-begin? c)
|
||
|
|
(inline isVector-end? c)
|
||
|
|
(inline isTree? c) )
|
||
|
|
|
||
|
|
(import (__error "Llib/error.scm")
|
||
|
|
(__match_s2cfun "Match/s2cfun.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")))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Renvoie la liste des variables apparaissant dans un filtre */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define (pattern-variables f)
|
||
|
|
(cond
|
||
|
|
((eq? (car f) 'or) (pattern-variables (cadr f)))
|
||
|
|
((eq? (car f) 't-or) (pattern-variables (cadr f)))
|
||
|
|
((eq? (car f) 'and) (union (pattern-variables (cadr f))
|
||
|
|
(pattern-variables (caddr f))))
|
||
|
|
((memq (car f) '(cons vector-cons))
|
||
|
|
(union (pattern-variables (cadr f))
|
||
|
|
(pattern-variables (caddr f))))
|
||
|
|
((memq (car f) '(tree times))
|
||
|
|
(union (pattern-variables (caddr f))
|
||
|
|
(pattern-variables (cadddr f))))
|
||
|
|
((eq? (car f) 'var) (cdr f))
|
||
|
|
((eq? (car f) 'vector-begin)
|
||
|
|
(pattern-variables (caddr f)) )
|
||
|
|
((eq? (car f) 'vector-end)
|
||
|
|
'() )
|
||
|
|
#|STk
|
||
|
|
((eq? (car f) 'struct-pat)
|
||
|
|
(let loop ((p* (cddr f)))
|
||
|
|
(if (null? p*)
|
||
|
|
'()
|
||
|
|
(union (pattern-variables (car p*))
|
||
|
|
(loop (cdr p*))))))
|
||
|
|
|#
|
||
|
|
(else '()) ) )
|
||
|
|
|
||
|
|
(define (union l1 l2)
|
||
|
|
(if (null? l1) l2
|
||
|
|
(if (member (car l1) l2)
|
||
|
|
(union (cdr l1) l2)
|
||
|
|
(cons (car l1) (union (cdr l1) l2)))))
|
||
|
|
|
||
|
|
(define (extend fn pt im)
|
||
|
|
(lambda (x) (if (eq? x pt) im (fn x))))
|
||
|
|
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Fonctions de mise a jour des descriptions */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Grammaire des descriptions: */
|
||
|
|
;;; descr ::= posD | negD | conjNegD */
|
||
|
|
;;; posD ::= (quote e) | (var v) | (cons Descr Descr) */
|
||
|
|
;;; | (and (var v) Descr)
|
||
|
|
;;; negD ::= (not (quote e)) | (not (var v)) | (not (cons (any)(any)*/
|
||
|
|
;;; conjNegD ::= (and negD conjNegD) | negD */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Intersection de deux descriptions */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define (pattern-plus old new)
|
||
|
|
(if (or (isTree? new) (isTimes? new))
|
||
|
|
; Perte d'information
|
||
|
|
old
|
||
|
|
(if (isAny? old)
|
||
|
|
new
|
||
|
|
(if (isAny? new)
|
||
|
|
old
|
||
|
|
(if (isNegation? old)
|
||
|
|
(norm-class new)
|
||
|
|
(norm-class (if (isVar? new)
|
||
|
|
(list 'and new old)
|
||
|
|
(list 'and old new))))))))
|
||
|
|
|
||
|
|
(define (pattern-minus p1 p2)
|
||
|
|
(if (or (not (or (isNegation? p1)
|
||
|
|
(isAny? p1) ;;; p1 is already a non empty affirmative
|
||
|
|
(isBottom? p1)))
|
||
|
|
(isTimes? p2) (isTree? p2)) ;;; we don't know how to handle p2
|
||
|
|
; Perte d'information
|
||
|
|
p1
|
||
|
|
(if (isAny? p1)
|
||
|
|
(list 'not p2)
|
||
|
|
(norm-class (list 'and p1 (list 'not p2))))))
|
||
|
|
|
||
|
|
;;; Une classe est une negation si et seulement si c'est un (not ...),
|
||
|
|
;;; ou un (and f1 f2), dont l'une des deux branches en est une. A noter que
|
||
|
|
;;; dans ce dernier cas, les deux branches sont forcement des negations,
|
||
|
|
;;; puisqu'une affirmative annule une negation.
|
||
|
|
(define (isNegation? c)
|
||
|
|
(or (and (eq? (car c) 'and)
|
||
|
|
(isNegation? (cadr c)))
|
||
|
|
(eq? (car c) 'not)))
|
||
|
|
|
||
|
|
(define (pattern-car c)
|
||
|
|
(if (eq? (car c) 'cons)
|
||
|
|
(cadr c)
|
||
|
|
'(any)))
|
||
|
|
|
||
|
|
(define (pattern-cdr c)
|
||
|
|
(if (eq? (car c) 'cons)
|
||
|
|
(caddr c)
|
||
|
|
'(any)))
|
||
|
|
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Normalisation des classes */
|
||
|
|
;;; Une classe peut etre: */
|
||
|
|
;;; (any) */
|
||
|
|
;;; (quote ...) */
|
||
|
|
;;; (not ...) */
|
||
|
|
;;; (and (not ...) (and (not ...) ...)) (conjonction de negations) */
|
||
|
|
;;; (and f1 (and f2 ...)) (conjonction d'affirmatives) */
|
||
|
|
;;; (cons f1 f2) */
|
||
|
|
;;; (tree/times n f1 f2) */
|
||
|
|
;;; Il faut noter qu'il n'y a pas de or, puisqu'une description */
|
||
|
|
;;; represente une information SURE. */
|
||
|
|
;;; Les regles utilisees sont: */
|
||
|
|
;;; (not (not c)) = c */
|
||
|
|
;;; (and (and f1 f2) f3) = (and f1 (and (f2 f3))) */
|
||
|
|
;;; (and (cons f1 f2) (cons f3 f4)) = (cons (and f1 f3)(and f2 f4))*/
|
||
|
|
;;; */
|
||
|
|
;;; Elles permettent notamment de s'assurer que toute classe */
|
||
|
|
;;; representant une liste a la forme (cons ...) */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
(define (norm-class c)
|
||
|
|
(norm c 'foo))
|
||
|
|
|
||
|
|
(define (norm c anc)
|
||
|
|
|
||
|
|
(cond
|
||
|
|
((equal? anc c) anc)
|
||
|
|
((eq? (car c) 'not) (norm-not (cadr c) ))
|
||
|
|
((eq? (car c) 'and) (norm-and (cadr c) (caddr c) ))
|
||
|
|
((eq? (car c) 'cons) (norm-cons (cadr c) (caddr c) ))
|
||
|
|
(else c)))
|
||
|
|
|
||
|
|
(define (norm-not c)
|
||
|
|
(norm (rewrite-not c) (list 'not c)))
|
||
|
|
|
||
|
|
(define (rewrite-not c)
|
||
|
|
(if (eq? (car c) 'not)
|
||
|
|
; (not (not c)) <==> c
|
||
|
|
(cadr c)
|
||
|
|
(list 'not (norm-class c))))
|
||
|
|
|
||
|
|
;;; A priori, c1 et c2 sont normalisees
|
||
|
|
(define (norm-and c1 c2)
|
||
|
|
(norm (rewrite-and c1 c2) (list 'and c1 c2)))
|
||
|
|
|
||
|
|
(define (rewrite-and c1 c2)
|
||
|
|
(cond
|
||
|
|
((equal? c1 c2) c1)
|
||
|
|
((eq? (car c1) 'and)
|
||
|
|
(list 'and
|
||
|
|
(cadr c1)
|
||
|
|
(list 'and
|
||
|
|
(caddr c1)
|
||
|
|
c2)))
|
||
|
|
((and (eq? (car c1) 'cons) (eq? (car c2) 'cons))
|
||
|
|
;;; and inutile: si c1 est un cons, c2 aussi ...
|
||
|
|
(list 'cons
|
||
|
|
(list 'and (cadr c1) (cadr c2))
|
||
|
|
(list 'and (caddr c1) (caddr c2))))
|
||
|
|
(else (list 'and c1 c2))))
|
||
|
|
|
||
|
|
(define (norm-cons c1 c2)
|
||
|
|
(list 'cons (norm-class c1) (norm-class c2)))
|
||
|
|
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Comparaison entre descriptions et filtres */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Le t-or presente une particularite par rapport au or normal, */
|
||
|
|
;;; c'est qu'il n'est plus precis que rien, pour respecter la */
|
||
|
|
;;; sequentialite des branches (cf match-case). */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
;;;-- Une description est-elle plus precise qu'un filtre ? ------------*/
|
||
|
|
(define (more-precise? descr f)
|
||
|
|
(cond
|
||
|
|
((isAny? descr) #f)
|
||
|
|
|
||
|
|
((eqv? (car f) 'any)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
((eqv? (car f) 'success)
|
||
|
|
#f)
|
||
|
|
|
||
|
|
((eqv? (car f) 'quote)
|
||
|
|
(and (isQuote? descr)
|
||
|
|
(equal? (cadr descr) (cadr f))))
|
||
|
|
|
||
|
|
((eqv? (car f) 'and)
|
||
|
|
(and (more-precise? descr (cadr f))
|
||
|
|
(more-precise? descr (caddr f))))
|
||
|
|
|
||
|
|
((eqv? (car f) 'or)
|
||
|
|
(or (more-precise? descr (cadr f))
|
||
|
|
(more-precise? descr (caddr f))))
|
||
|
|
|
||
|
|
((eqv? (car f) 't-or)
|
||
|
|
#f)
|
||
|
|
|
||
|
|
((memq (car f) '(cons acons xcons))
|
||
|
|
(and (isCons? descr)
|
||
|
|
(more-precise? (cadr descr) (cadr f))
|
||
|
|
(more-precise? (caddr descr) (caddr f))))
|
||
|
|
|
||
|
|
((eqv? (car f) 'vector-begin)
|
||
|
|
#f) ;;;(and (isVector? descr)
|
||
|
|
|
||
|
|
|
||
|
|
(else #f)))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Test de compatibilite entre filtre et description. */
|
||
|
|
;;; Le filtre tree est similaire a (any) */
|
||
|
|
;;; A noter que si le filtre est un or, ce n'est pas */
|
||
|
|
;;; la peine de s'embeter. Autant attendre le filtrage des */
|
||
|
|
;;; alternatives, cela permet de ne comparer que des choses "sures" */
|
||
|
|
;;; A noter egalement que j'alpha-convertis le filtre, */
|
||
|
|
;;; ce qui me permet de n'utiliser qu'un seul environnement. */
|
||
|
|
;;; L'ordre est clairement GAUCHE-DROITE. */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Cette fonction est CONSERVATIVE: elle fait parfois des erreurs, */
|
||
|
|
;;; mais toujours dans le sens d'une perte d'information. */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
(define (compatible? descr pattern)
|
||
|
|
(let ((res
|
||
|
|
;;;-- Les filtres composes --------------------------------------------*/
|
||
|
|
(if (isAnd? pattern)
|
||
|
|
(and (compatible? descr (cadr pattern))
|
||
|
|
(compatible? descr (caddr pattern)))
|
||
|
|
;;;-- Les filtres "de base" -------------------------------------------*/
|
||
|
|
(compare descr
|
||
|
|
(alpha-convert pattern)
|
||
|
|
(lambda (x) 'unbound)
|
||
|
|
(lambda (x) #t)
|
||
|
|
(lambda (x) #f)))) )
|
||
|
|
res))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; A ce stade, pat ne peut pas etre Or, t-Or, success, and */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Grammaire des descriptions: */
|
||
|
|
;;; descr ::= posD | negD | conjNegD */
|
||
|
|
;;; posD ::= (quote e) | (var v) | (cons Descr Descr) */
|
||
|
|
;;; | (and (var v) Descr)
|
||
|
|
;;; negD ::= (not (quote e)) | (not (var v)) | (not (cons (any)(any)*/
|
||
|
|
;;; conjNegD ::= (and negD conjNegD) | negD */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Le cas ou l'un ou l'autre est une variable est traite ici */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
(define (compare descr pat env k z)
|
||
|
|
|
||
|
|
(cond
|
||
|
|
((or (isAny? descr)
|
||
|
|
(isAny? pat)
|
||
|
|
(isOr? pat) (isT-Or? pat) (isTagged-or? pat)
|
||
|
|
(isSuccess? pat)
|
||
|
|
(isCheck? pat)
|
||
|
|
(isTimes? pat)
|
||
|
|
(isTree? pat))
|
||
|
|
(k env))
|
||
|
|
|
||
|
|
((isAnd? pat)
|
||
|
|
(compare descr (cadr pat) env
|
||
|
|
(lambda (env) (compare descr (caddr pat) env k z))
|
||
|
|
z))
|
||
|
|
|
||
|
|
((isCons? pat)
|
||
|
|
(if (may-be-a-cons descr)
|
||
|
|
(compare (pattern-car descr) (cadr pat) env
|
||
|
|
(lambda (env)
|
||
|
|
(compare (pattern-cdr descr)
|
||
|
|
(caddr pat) env k z) )
|
||
|
|
z)
|
||
|
|
(z env)))
|
||
|
|
|
||
|
|
;;;-- Si le filtre est une valeur, il suffit de la filtrer par --------*/
|
||
|
|
;;;-- la description... non ? -----------------------------------------*/
|
||
|
|
((isQuote? pat)
|
||
|
|
(match descr (cadr pat) env k z))
|
||
|
|
|
||
|
|
((and (isVar? descr) (isVar? pat))
|
||
|
|
(if (eq? (env (cadr descr)) 'unbound)
|
||
|
|
(if (eq? (env (cadr pat)) 'unbound)
|
||
|
|
(let ((s (list 'quote (jim-gensym))))
|
||
|
|
(k (extend (extend env (cadr descr) s)
|
||
|
|
(cadr pat)
|
||
|
|
s)))
|
||
|
|
(k (extend env (cadr descr) (env (cadr pat)))))
|
||
|
|
(if (eq? (env (cadr pat)) 'unbound)
|
||
|
|
(k (extend env (cadr pat) (env (cadr descr))))
|
||
|
|
(compare (env (cadr descr)) (env (cadr pat)) env k z))))
|
||
|
|
|
||
|
|
((isVar? pat)
|
||
|
|
(if (eq? (env (cadr pat)) 'unbound)
|
||
|
|
(k (extend env (cadr pat) descr))
|
||
|
|
(compare descr (env (cadr pat)) env k z)) )
|
||
|
|
|
||
|
|
((isVar? descr)
|
||
|
|
(if (eq? (env (cadr descr)) 'unbound)
|
||
|
|
(k (extend env (cadr descr) pat))
|
||
|
|
(compare descr (env (cadr descr)) env k z)) )
|
||
|
|
|
||
|
|
((isNot? pat) (if (more-precise? (cadr pat) descr)
|
||
|
|
(z env)
|
||
|
|
(k env) ) )
|
||
|
|
|
||
|
|
((isVector-begin? pat)
|
||
|
|
(if (isAny? descr)
|
||
|
|
#t
|
||
|
|
(if (isVector? descr)
|
||
|
|
; la, je matche la descr. avec le pattern,
|
||
|
|
; pcq + facile (la descr. est 1 vecteur)
|
||
|
|
(match pat descr env k z)
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(else (k env) ) ) )
|
||
|
|
|
||
|
|
(define (may-be-a-cons descr)
|
||
|
|
(if (equal? descr '(not (cons (any) (any))))
|
||
|
|
#f
|
||
|
|
(if (isAnd? descr)
|
||
|
|
(and (may-be-a-cons (cadr descr))
|
||
|
|
(may-be-a-cons (caddr descr)))
|
||
|
|
#t) ) )
|
||
|
|
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Filtrage d'une expression par une DESCRIPION */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define (match d e env k z)
|
||
|
|
|
||
|
|
(case (car d)
|
||
|
|
((any) (k env))
|
||
|
|
|
||
|
|
((quote) (if (eq? e (cadr d)) (k env) (z env)))
|
||
|
|
|
||
|
|
((and) (match (cadr d) e env
|
||
|
|
(lambda (env)
|
||
|
|
(match (caddr d) e env k z))
|
||
|
|
z) )
|
||
|
|
|
||
|
|
((cons) (if (pair? e)
|
||
|
|
(match (cadr d) (car e) env
|
||
|
|
(lambda (env)
|
||
|
|
(match (caddr d) (cdr e) env k z))
|
||
|
|
z)
|
||
|
|
(z env) ) )
|
||
|
|
|
||
|
|
;;;-- Une regle particuliere pcq on peut avoir des (not (var x)) ------*/
|
||
|
|
;;;-- avec x non lie. -------------------------------------------------*/
|
||
|
|
((not)
|
||
|
|
(if (isVar? (cadr d))
|
||
|
|
(let ((s (jim-gensym "VAR-")))
|
||
|
|
(k (extend env (cadadr d) `(not (quote s)))))
|
||
|
|
(match (cadr d) e env z k)))
|
||
|
|
|
||
|
|
;;;-- Le cas ou la descr. est un vector et le filtre un vector-begin --*/
|
||
|
|
;;;-- Attention: d est ici le filtre ----------------------------------*/
|
||
|
|
((vector-begin)
|
||
|
|
((match (caddr d) (caddr e) env k z) 0))
|
||
|
|
|
||
|
|
((vector-cons)
|
||
|
|
(lambda (i)
|
||
|
|
(if (>=fx i (vector-length e))
|
||
|
|
(k env)
|
||
|
|
(compare (cadr d) (vector-ref e i)
|
||
|
|
env
|
||
|
|
(lambda (env)
|
||
|
|
((match (caddr d) e env k z)
|
||
|
|
(+fx i 1)))
|
||
|
|
z ))))
|
||
|
|
|
||
|
|
((vector-end)
|
||
|
|
(lambda (i) (k env)))
|
||
|
|
|
||
|
|
((var) (if (eq? (env (cadr d)) 'unbound)
|
||
|
|
(k (extend env (cadr d) e))
|
||
|
|
(if (eq? (env (cadr d)) e)
|
||
|
|
(k env)
|
||
|
|
(z env)))) ) )
|
||
|
|
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Alpha-conversion d'un filtre */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define (alpha-convert f)
|
||
|
|
(let loop ( (f f)
|
||
|
|
(env (lambda (x) 'unbound))
|
||
|
|
(k (lambda (f e) f)) )
|
||
|
|
(cond
|
||
|
|
((or (boolean? f) (symbol? f) (string? f) (integer? f) )
|
||
|
|
(k f env))
|
||
|
|
((null? f)
|
||
|
|
(k f env))
|
||
|
|
((equal? (car f) 'quote)
|
||
|
|
(k f env))
|
||
|
|
((eq? (car f) 'var)
|
||
|
|
(if (eq? (env (cadr f)) 'unbound)
|
||
|
|
(let ((s (jim-gensym)))
|
||
|
|
(k (list 'var s) (extend env (cadr f) s)))
|
||
|
|
(k (list 'var (env (cadr f))) env)))
|
||
|
|
(else (loop (car f) env
|
||
|
|
(lambda (fcar e)
|
||
|
|
(loop (cdr f) e
|
||
|
|
(lambda (fcdr e)
|
||
|
|
(k (cons fcar fcdr) e)))))))))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Les inlines */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define-inline (isAny? c) (if (eq? (car c) 'any)
|
||
|
|
#t
|
||
|
|
(eq? (car c) 'check)))
|
||
|
|
|
||
|
|
(define-inline (isCheck? c) (eq? (car c) 'check))
|
||
|
|
|
||
|
|
(define-inline (isSuccess? c) (eq? (car c) 'success))
|
||
|
|
|
||
|
|
(define-inline (isTop? c) (eq? (car c) 'top))
|
||
|
|
|
||
|
|
(define-inline (isBottom? c) (eq? (car c) 'bottom))
|
||
|
|
|
||
|
|
(define-inline (isQuote? c) (eq? (car c) 'quote))
|
||
|
|
|
||
|
|
(define-inline (isVar? c) (eq? (car c) 'var))
|
||
|
|
|
||
|
|
(define-inline (isNot? c) (eq? (car c) 'not))
|
||
|
|
|
||
|
|
(define-inline (isAnd? c) (eq? (car c) 'and))
|
||
|
|
|
||
|
|
(define-inline (isOr? c) (eq? (car c) 'or))
|
||
|
|
|
||
|
|
(define-inline (isT-Or? c) (eq? (car c) 't-or))
|
||
|
|
|
||
|
|
(define-inline (isTagged-Or? c) (eq? (car c) 'tagged-or))
|
||
|
|
|
||
|
|
(define-inline (isCons? c) (eq? (car c) 'cons))
|
||
|
|
|
||
|
|
(define-inline (isACons? c) (eq? (car c) 'acons))
|
||
|
|
|
||
|
|
(define-inline (isXCons? c) (eq? (car c) 'xcons))
|
||
|
|
|
||
|
|
(define-inline (isTimes? c) (eq? (car c) 'times))
|
||
|
|
|
||
|
|
(define-inline (containsHole? c) (eq? (car c) 'hole))
|
||
|
|
|
||
|
|
(define-inline (isHole? c) (eq? (car c) 'hole))
|
||
|
|
|
||
|
|
(define-inline (isTree? c) (eq? (car c) 'tree))
|
||
|
|
|
||
|
|
(define-inline (isVector? c) (eq? (car c) 'vector))
|
||
|
|
|
||
|
|
(define-inline (isVector-begin? c) (eq? (car c) 'vector-begin))
|
||
|
|
|
||
|
|
(define-inline (isVector-end? c) (eq? (car c) 'vector-end))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; (Vector-Plus v i d) updates the ith element of the description */
|
||
|
|
;;; with d. */
|
||
|
|
;;; The caddr of the descr can be too short. We must be able */
|
||
|
|
;;; to extend it. */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
|
||
|
|
(define (Vector-Plus v i d)
|
||
|
|
(if (>=fx i (vector-length (caddr v)))
|
||
|
|
(set-car! (cddr v)
|
||
|
|
(extend-vector (caddr v) i '(any)))
|
||
|
|
#t)
|
||
|
|
(let ((res `(vector ,(vector-length (caddr v))
|
||
|
|
,(list->vector (vector->list (caddr v))))))
|
||
|
|
(vector-set! (caddr res) i
|
||
|
|
(pattern-plus (vector-ref (caddr v) i) d))
|
||
|
|
res))
|
||
|
|
|
||
|
|
(define (Vector-Minus v i d)
|
||
|
|
(if (>=fx i (vector-length (caddr v)))
|
||
|
|
(set-car! (cddr v)
|
||
|
|
(extend-vector (caddr v) i '(any)))
|
||
|
|
#t)
|
||
|
|
(let ((res `(vector ,(length (caddr v))
|
||
|
|
,(list->vector (vector->list (caddr v))))))
|
||
|
|
(vector-set! (caddr res) i
|
||
|
|
(pattern-minus (vector-ref (caddr v) i) d))
|
||
|
|
res))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; Extend-vector allocates a new longer vector and fills */
|
||
|
|
;;; its first elements with the ones of v */
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
(define (extend-vector v lg fill)
|
||
|
|
(let ((res
|
||
|
|
(let ((new-vector (make-vector lg fill)))
|
||
|
|
(let loop ((i 0))
|
||
|
|
(if (=fx i (vector-length v))
|
||
|
|
new-vector
|
||
|
|
(begin
|
||
|
|
(vector-set! new-vector i (vector-ref v i))
|
||
|
|
(loop (+fx i 1))))))))
|
||
|
|
res))
|
||
|
|
|
||
|
|
;;;--------------------------------------------------------------------*/
|
||
|
|
;;; End of file... */
|
||
|
|
;;;--------------------------------------------------------------------*/
|