Ported match.ss to ikarus.
This commit is contained in:
Abdulaziz Ghuloum
parent
09a02059c6
commit
54f683f0e0
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
(source "r6rs.ss")
|
||||
(source "parameters.ss")
|
||||
(source "match.ss")
|
||||
(source "interp.ss")
|
||||
|
||||
(library main
|
||||
(export)
|
||||
(import interp r6rs)
|
||||
(write (ee '(let ((x 5))
|
||||
(let ((y (+ x x)))
|
||||
(+ y x)))))
|
||||
(newline))
|
||||
|
||||
(invoke main)
|
||||
;(dump main "main.pp")
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
|
||||
|
||||
(library interp
|
||||
(export ee)
|
||||
(import match r6rs)
|
||||
(define (constant? x)
|
||||
(or (number? x) (char? x) (string? x) (boolean? x)))
|
||||
(define (ee x)
|
||||
(define (ee x env)
|
||||
(match x
|
||||
(,c (guard (constant? c)) c)
|
||||
(,x (guard (symbol? x))
|
||||
(cond
|
||||
((assq x env) => cdr)
|
||||
(else (error 'ee "unbound ~s" x))))
|
||||
((let ((,x ,v)) ,b)
|
||||
(ee b (cons (cons x (ee v env)) env)))
|
||||
((+ ,(x) ,(y)) (+ x y))
|
||||
(,others (error 'ee "invalid expr ~s" others))))
|
||||
(ee x '())))
|
||||
|
||||
|
|
@ -0,0 +1,855 @@
|
|||
;;; match.ss
|
||||
|
||||
;;; This program was originally designed and implemented by Dan
|
||||
;;; Friedman. It was redesigned and implemented by Erik Hilsdale;
|
||||
;;; some improvements were suggested by Steve Ganz. Additional
|
||||
;;; modifications were made by Kent Dybvig.
|
||||
|
||||
;; (Nov 2007)
|
||||
;; Aziz Ghuloum added it to ikarus.
|
||||
|
||||
;; (Apr 2007)
|
||||
;; Aziz Ghuloum ported it to r6rs.
|
||||
|
||||
;; (13 March 2002)
|
||||
;; rkd added following change by Friedman and Ganz to the main source
|
||||
;; code thread and fixed a couple of minor problems.
|
||||
|
||||
;; (9 March 2002)
|
||||
;; Dan Friedman and Steve Ganz added the ability to use identical pattern
|
||||
;; variables. The patterns represented by the variables are compared
|
||||
;; using the value of the parameter match-equality-test, which defaults
|
||||
;; to equal?.
|
||||
;;
|
||||
;; > (match '(1 2 1 2 1)
|
||||
;; ((,a ,b ,a ,b ,a) (guard (number? a) (number? b)) (+ a b)))
|
||||
;; 3
|
||||
;; ;;
|
||||
;; > (match '((1 2 3) 5 (1 2 3))
|
||||
;; (((,a ...) ,b (,a ...)) `(,a ... ,b)))
|
||||
;; (1 2 3 5)
|
||||
;; ;;
|
||||
;; > (parameterize ((match-equality-test (lambda (x y) (equal? x (reverse y)))))
|
||||
;; (match '((1 2 3) (3 2 1))
|
||||
;; ((,a ,a) 'yes)
|
||||
;; (,oops 'no)))
|
||||
;; yes
|
||||
|
||||
;; (10 Jan 2002)
|
||||
;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to
|
||||
;; blow up. The bug was caused by a bug in the sexp-dispatch procedure
|
||||
;; where a base value empty list was passed to an accumulator from inside
|
||||
;; the recursion, instead of passing the old value of the accumulator.
|
||||
|
||||
;; (14 Jan 2001)
|
||||
;; rkd added syntax checks to unquote pattern parsing to weed out invalid
|
||||
;; patterns like ,#(a) and ,((vector-ref d 1)).
|
||||
|
||||
;; (14 Jan 2001)
|
||||
;; rkd added ,(Cata -> Id* ...) to allow specification of recursion
|
||||
;; function. ,(Id* ...) recurs to match; ,(Cata -> Id* ...) recurs
|
||||
;; to Cata.
|
||||
|
||||
;; (14 Jan 2001)
|
||||
;; rkd tightened up checks for ellipses and nested quasiquote; was comparing
|
||||
;; symbolic names, which, as had been noted in the source, is a possible
|
||||
;; hygiene bug. Replaced error call in guard-body with syntax-error to
|
||||
;; allow error to include source line/character information.
|
||||
|
||||
;; (13 Jan 2001)
|
||||
;; rkd fixed match patterns of the form (stuff* ,(x) ... stuff+), which
|
||||
;; had been recurring on subforms of each item rather than on the items
|
||||
;; themselves.
|
||||
|
||||
;; Previous changelog listings at end of file.
|
||||
|
||||
;;; ============================================================
|
||||
|
||||
;; Exp ::= (match Exp Clause)
|
||||
;; || (trace-match Exp Clause)
|
||||
;; || (match+ (Id*) Exp Clause*)
|
||||
;; || (trace-match+ (Id*) Exp Clause*)
|
||||
;; || OtherSchemeExp
|
||||
|
||||
;; Clause ::= (Pat Exp+) || (Pat (guard Exp*) Exp+)
|
||||
|
||||
;; Pat ::= (Pat ... . Pat)
|
||||
;; || (Pat . Pat)
|
||||
;; || ()
|
||||
;; || #(Pat* Pat ... Pat*)
|
||||
;; || #(Pat*)
|
||||
;; || ,Id
|
||||
;; || ,(Id*)
|
||||
;; || ,(Cata -> Id*)
|
||||
;; || Id
|
||||
|
||||
;; Cata ::= Exp
|
||||
|
||||
;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!)
|
||||
|
||||
|
||||
|
||||
|
||||
(library (match)
|
||||
(export match trace-match guard ... quasiquote unquote
|
||||
unquote-splicing)
|
||||
(import (ikarus))
|
||||
|
||||
(define-syntax rec
|
||||
(syntax-rules ()
|
||||
[(_ name val)
|
||||
(letrec ([name val]) name)]))
|
||||
|
||||
(define match-equality-test
|
||||
(make-parameter
|
||||
equal?
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
(error 'match-equality-test "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define-syntax match+
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((ctxt (ThreadedId ...) Exp Clause ...)
|
||||
#'(let f ((ThreadedId ThreadedId) ... (x Exp))
|
||||
(match-help ctxt f x (ThreadedId ...) Clause ...))))))
|
||||
|
||||
(define-syntax match
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((ctxt Exp Clause ...)
|
||||
#'(let f ((x Exp))
|
||||
(match-help ctxt f x () Clause ...))))))
|
||||
|
||||
(define-syntax trace-match+
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((ctxt (ThreadedId ...) Name Exp Clause ...)
|
||||
#'(letrec ((f (trace-lambda Name (ThreadedId ... x)
|
||||
(match-help ctxt f x (ThreadedId ...) Clause ...))))
|
||||
(f ThreadedId ... x))))))
|
||||
|
||||
(define-syntax trace-match
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((ctxt Name Exp Clause ...)
|
||||
#'(letrec ((f (trace-lambda Name (x)
|
||||
(match-help ctxt f x () Clause ...))))
|
||||
(f Exp))))))
|
||||
|
||||
;;; ------------------------------
|
||||
|
||||
(define-syntax let-values**
|
||||
(syntax-rules ()
|
||||
((_ () B0 B ...) (begin B0 B ...))
|
||||
((_ ((Formals Exp) Rest ...) B0 B ...)
|
||||
(let-values** (Rest ...)
|
||||
(call-with-values (lambda () Exp)
|
||||
(lambda Formals B0 B ...))))))
|
||||
|
||||
(define-syntax match-help
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ Template Cata Obj ThreadedIds)
|
||||
#'(error 'match "Unmatched datum" Obj))
|
||||
((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...)
|
||||
#'(convert-pat Pat
|
||||
(match-help1 Template Cata Obj ThreadedIds
|
||||
(B0 B ...)
|
||||
Rest ...))))))
|
||||
|
||||
(define-syntax match-help1
|
||||
(lambda (x)
|
||||
(syntax-case x (guard)
|
||||
((_ PatLit Vars () Cdecls Template Cata Obj ThreadedIds
|
||||
((guard) B0 B ...) Rest ...)
|
||||
#'(let ((ls/false (sexp-dispatch Obj PatLit)))
|
||||
(if ls/false
|
||||
(apply (lambda Vars
|
||||
(clause-body Cata Cdecls ThreadedIds
|
||||
(extend-backquote Template B0 B ...)))
|
||||
ls/false)
|
||||
(match-help Template Cata Obj ThreadedIds Rest ...))))
|
||||
((_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
|
||||
((guard G ...) B0 B ...) Rest ...)
|
||||
#'(let ((ls/false (sexp-dispatch Obj PatLit)))
|
||||
(if (and ls/false (apply (lambda Vars
|
||||
(guard-body Cdecls
|
||||
(extend-backquote Template
|
||||
(and PG ... G ...))))
|
||||
ls/false))
|
||||
(apply (lambda Vars
|
||||
(clause-body Cata Cdecls ThreadedIds
|
||||
(extend-backquote Template B0 B ...)))
|
||||
ls/false)
|
||||
(match-help Template Cata Obj ThreadedIds Rest ...))))
|
||||
((_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
|
||||
(B0 B ...) Rest ...)
|
||||
#'(match-help1 PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
|
||||
((guard) B0 B ...) Rest ...)))))
|
||||
|
||||
(define-syntax clause-body
|
||||
(lambda (x)
|
||||
(define build-mapper
|
||||
(lambda (vars depth cata tIds)
|
||||
(if (zero? depth)
|
||||
cata
|
||||
(with-syntax ((rest (build-mapper vars (- depth 1) cata tIds))
|
||||
(vars vars)
|
||||
(tIds tIds))
|
||||
#'(mapper rest vars tIds)))))
|
||||
(syntax-case x ()
|
||||
((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B)
|
||||
(with-syntax (((Mapper ...)
|
||||
(map (lambda (mycata formals depth)
|
||||
(build-mapper formals
|
||||
(syntax->datum depth)
|
||||
(syntax-case mycata ()
|
||||
(#f #'Cata)
|
||||
(exp #'exp))
|
||||
#'(ThreadedId ...)))
|
||||
#'(CMyCata ...)
|
||||
#'((CFormal ...) ...)
|
||||
#'(CDepth ...))))
|
||||
#'(let-values** (((ThreadedId ... CFormal ...)
|
||||
(Mapper ThreadedId ... CVar))
|
||||
...)
|
||||
B))))))
|
||||
|
||||
(define-syntax guard-body
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ ((Cvar Cdepth MyCata Cformal ...) ...) B)
|
||||
(with-syntax (((CF ...) (apply append #'((Cformal ...) ...))))
|
||||
#'(let-syntax
|
||||
((CF
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
(Name
|
||||
(syntax-error #'Name
|
||||
"guard cannot refer to return-value variable")))))
|
||||
...)
|
||||
B))))))
|
||||
|
||||
(define-syntax convert-pat
|
||||
;; returns sexp-pat x vars x guards x cdecls
|
||||
(let ()
|
||||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (identifier? x) (free-identifier=? x #'(... ...)))))
|
||||
(define Var?
|
||||
(lambda (x)
|
||||
(syntax-case x (->)
|
||||
(-> #f)
|
||||
(id (identifier? #'id)))))
|
||||
(define fVar
|
||||
(lambda (var vars guards)
|
||||
(let loop ((ls vars))
|
||||
(if (null? ls)
|
||||
(values (cons var vars) guards)
|
||||
(if (bound-identifier=? var (car ls))
|
||||
(with-syntax (((tmp) (generate-temporaries (list var)))
|
||||
(var (car ls)))
|
||||
(values (cons #'tmp vars)
|
||||
(cons #'((match-equality-test) tmp var) guards)))
|
||||
(loop (cdr ls)))))))
|
||||
(define (f syn vars guards cdecls depth)
|
||||
(define (andmap f ls)
|
||||
(cond
|
||||
((null? ls) #f)
|
||||
((null? (cdr ls)) (f (car ls)))
|
||||
(else (and (f (car ls)) (andmap f (cdr ls))))))
|
||||
(syntax-case syn (unquote)
|
||||
((unquote . stuff) ; separate for better error detection
|
||||
(syntax-case syn (unquote ->)
|
||||
((unquote (MyCata -> Var ...))
|
||||
(andmap Var? #'(Var ...))
|
||||
(with-syntax (((Temp) (generate-temporaries '(x)))
|
||||
(Depth depth))
|
||||
(values #'any
|
||||
(cons #'Temp vars)
|
||||
guards
|
||||
(cons #'(Temp Depth MyCata Var ...) cdecls))))
|
||||
((unquote (Var ...))
|
||||
(andmap Var? #'(Var ...))
|
||||
(with-syntax (((Temp) (generate-temporaries '(x)))
|
||||
(Depth depth))
|
||||
(values #'any
|
||||
(cons #'Temp vars)
|
||||
guards
|
||||
(cons #'(Temp Depth #f Var ...) cdecls))))
|
||||
((unquote Var)
|
||||
(Var? #'Var)
|
||||
(let-values* (((vars guards) (fVar #'Var vars guards)))
|
||||
(values #'any vars guards cdecls)))))
|
||||
(((unquote . stuff) Dots)
|
||||
(ellipsis? #'Dots)
|
||||
(syntax-case syn (unquote ->)
|
||||
(((unquote (MyCata -> Var ...)) Dots)
|
||||
(andmap Var? #'(Var ...))
|
||||
(with-syntax (((Temp) (generate-temporaries '(x)))
|
||||
(Depth+1 (add1 depth)))
|
||||
(values #'each-any
|
||||
(cons #'Temp vars)
|
||||
guards
|
||||
(cons #'(Temp Depth+1 MyCata Var ...) cdecls))))
|
||||
(((unquote (Var ...)) Dots)
|
||||
(andmap Var? #'(Var ...))
|
||||
(with-syntax (((Temp) (generate-temporaries '(x)))
|
||||
(Depth+1 (add1 depth)))
|
||||
(values #'each-any
|
||||
(cons #'Temp vars)
|
||||
guards
|
||||
(cons #'(Temp Depth+1 #f Var ...) cdecls))))
|
||||
(((unquote Var) Dots)
|
||||
(Var? #'Var)
|
||||
(let-values* (((vars guards) (fVar #'Var vars guards)))
|
||||
(values #'each-any vars guards cdecls)))
|
||||
((expr Dots) (syntax-error #'expr "match-pattern unquote syntax"))))
|
||||
((Pat Dots)
|
||||
(ellipsis? #'Dots)
|
||||
(let-values* (((Dpat Dvars Dguards Dcdecls)
|
||||
(f #'Pat vars guards cdecls (add1 depth))))
|
||||
(with-syntax ((Size (- (length Dvars) (length vars)))
|
||||
(Dpat Dpat))
|
||||
(values #'#(each Dpat Size) Dvars Dguards Dcdecls))))
|
||||
((Pat Dots . Rest)
|
||||
(ellipsis? #'Dots)
|
||||
(let-values* (((Rpat Rvars Rguards Rcdecls)
|
||||
(f #'Rest vars guards cdecls depth))
|
||||
((Dpat Dvars Dguards Dcdecls)
|
||||
(f #'(Pat (... ...)) Rvars Rguards Rcdecls depth)))
|
||||
(with-syntax ((Size (- (length Dvars) (length Rvars)))
|
||||
((RevRestTl . RevRest) (reverseX Rpat '()))
|
||||
(Dpat Dpat))
|
||||
(values #'#(tail-each Dpat Size RevRest RevRestTl)
|
||||
Dvars Dguards Dcdecls))))
|
||||
((X . Y)
|
||||
(let-values* (((Ypat Yvars Yguards Ycdecls)
|
||||
(f #'Y vars guards cdecls depth))
|
||||
((Xpat Xvars Xguards Xcdecls)
|
||||
(f #'X Yvars Yguards Ycdecls depth)))
|
||||
(with-syntax ((Xpat Xpat) (Ypat Ypat))
|
||||
(values #'(Xpat . Ypat) Xvars Xguards Xcdecls))))
|
||||
(() (values #'() vars guards cdecls))
|
||||
(#(X ...)
|
||||
(let-values* (((Pat Vars Eqvars Cdecls)
|
||||
(f #'(X ...) vars guards cdecls depth)))
|
||||
(with-syntax ((Pat Pat))
|
||||
(values #'#(vector Pat) Vars Eqvars Cdecls))))
|
||||
(Thing (values #'#(atom Thing) vars guards cdecls))))
|
||||
(define reverseX
|
||||
(lambda (ls acc)
|
||||
(if (pair? ls)
|
||||
(reverseX (cdr ls) (cons (car ls) acc))
|
||||
(cons ls acc))))
|
||||
(define-syntax let-values*
|
||||
(syntax-rules ()
|
||||
((_ () B0 B ...) (begin B0 B ...))
|
||||
((_ (((Formal ...) Exp) Decl ...) B0 B ...)
|
||||
(call-with-values (lambda () Exp)
|
||||
(lambda (Formal ...)
|
||||
(let-values* (Decl ...) B0 B ...))))))
|
||||
(define-syntax let-synvalues*
|
||||
(syntax-rules ()
|
||||
((_ () B0 B ...) (begin B0 B ...))
|
||||
((_ (((Formal ...) Exp) Decl ...) B0 B ...)
|
||||
(call-with-values (lambda () Exp)
|
||||
(lambda (Formal ...)
|
||||
(with-syntax ((Formal Formal) ...)
|
||||
(let-synvalues* (Decl ...) B0 B ...)))))))
|
||||
(lambda (syn)
|
||||
(syntax-case syn ()
|
||||
((_ syn (kh . kt))
|
||||
(let-synvalues* (((Pat Vars Guards Cdecls) (f #'syn '() '() '() 0)))
|
||||
#'(kh 'Pat Vars Guards Cdecls . kt)))))))
|
||||
|
||||
(define-syntax mapper
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ F (RetId ...) (ThreadId ...))
|
||||
(with-syntax (((t ...) (generate-temporaries #'(RetId ...)))
|
||||
((ts ...) (generate-temporaries #'(RetId ...)))
|
||||
((null ...) (map (lambda (x) #''()) #'(RetId ...))))
|
||||
#'(let ((fun F))
|
||||
(rec g
|
||||
(lambda (ThreadId ... ls)
|
||||
(if (null? ls)
|
||||
(values ThreadId ... null ...)
|
||||
(call-with-values
|
||||
(lambda () (g ThreadId ... (cdr ls)))
|
||||
(lambda (ThreadId ... ts ...)
|
||||
(call-with-values
|
||||
(lambda () (fun ThreadId ... (car ls)))
|
||||
(lambda (ThreadId ... t ...)
|
||||
(values ThreadId ... (cons t ts) ...))))))))))))))
|
||||
|
||||
;;; ------------------------------
|
||||
|
||||
(define-syntax my-backquote
|
||||
(lambda (x)
|
||||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (identifier? x) (free-identifier=? x #'(... ...)))))
|
||||
(define-syntax with-values
|
||||
(syntax-rules ()
|
||||
((_ P C) (call-with-values (lambda () P) C))))
|
||||
(define-syntax syntax-lambda
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (Pat ...) Body0 Body ...)
|
||||
(with-syntax (((X ...) (generate-temporaries #'(Pat ...))))
|
||||
#'(lambda (X ...)
|
||||
(with-syntax ((Pat X) ...)
|
||||
Body0 Body ...)))))))
|
||||
(define-syntax with-temp
|
||||
(syntax-rules ()
|
||||
((_ V Body0 Body ...)
|
||||
(with-syntax (((V) (generate-temporaries '(x))))
|
||||
Body0 Body ...))))
|
||||
(define-syntax with-temps
|
||||
(syntax-rules ()
|
||||
((_ (V ...) (Exp ...) Body0 Body ...)
|
||||
(with-syntax (((V ...) (generate-temporaries #'(Exp ...))))
|
||||
Body0 Body ...))))
|
||||
(define destruct
|
||||
(lambda (Orig x depth)
|
||||
(syntax-case x (quasiquote unquote unquote-splicing)
|
||||
;; inner quasiquote
|
||||
((quasiquote Exp)
|
||||
(with-values (destruct Orig #'Exp (add1 depth))
|
||||
(syntax-lambda (Builder Vars Exps)
|
||||
(if (null? #'Vars)
|
||||
(values #''(quasiquote Exp) '() '())
|
||||
(values #'(list 'quasiquote Builder) #'Vars #'Exps)))))
|
||||
;; unquote
|
||||
((unquote Exp)
|
||||
(zero? depth)
|
||||
(with-temp X
|
||||
(values #'X (list #'X) (list #'Exp))))
|
||||
((unquote Exp)
|
||||
(with-values (destruct Orig #'Exp (sub1 depth))
|
||||
(syntax-lambda (Builder Vars Exps)
|
||||
(if (null? #'Vars)
|
||||
(values #''(unquote Exp) '() '())
|
||||
(values #'(list 'unquote Builder) #'Vars #'Exps)))))
|
||||
;; splicing
|
||||
(((unquote-splicing Exp))
|
||||
(zero? depth)
|
||||
(with-temp X
|
||||
(values #'X (list #'X) (list #'Exp))))
|
||||
(((unquote-splicing Exp ...))
|
||||
(zero? depth)
|
||||
(with-temps (X ...) (Exp ...)
|
||||
(values #'(append X ...) #'(X ...) #'(Exp ...))))
|
||||
(((unquote-splicing Exp ...) . Rest)
|
||||
(zero? depth)
|
||||
(with-values (destruct Orig #'Rest depth)
|
||||
(syntax-lambda (Builder Vars Exps)
|
||||
(with-temps (X ...) (Exp ...)
|
||||
(if (null? #'Vars)
|
||||
(values #'(append X ... 'Rest)
|
||||
#'(X ...) #'(Exp ...))
|
||||
(values #'(append X ... Builder)
|
||||
#'(X ... . Vars) #'(Exp ... . Exps)))))))
|
||||
((unquote-splicing Exp ...)
|
||||
(with-values (destruct Orig #'(Exp ...) (sub1 depth))
|
||||
(syntax-lambda (Builder Vars Exps)
|
||||
(if (null? #'Vars)
|
||||
(values #''(unquote-splicing Exp ...) '() '())
|
||||
(values #'(cons 'unquote-splicing Builder)
|
||||
#'Vars #'Exps)))))
|
||||
;; dots
|
||||
(((unquote Exp) Dots)
|
||||
(and (zero? depth) (ellipsis? #'Dots))
|
||||
(with-temp X
|
||||
(values #'X (list #'X) (list #'Exp))))
|
||||
(((unquote Exp) Dots . Rest)
|
||||
(and (zero? depth) (ellipsis? #'Dots))
|
||||
(with-values (destruct Orig #'Rest depth)
|
||||
(syntax-lambda (RestBuilder RestVars RestExps)
|
||||
(with-syntax ((TailExp
|
||||
(if (null? #'RestVars)
|
||||
#''Rest
|
||||
#'RestBuilder)))
|
||||
(with-temp X
|
||||
(values #'(append X TailExp)
|
||||
(cons #'X #'RestVars)
|
||||
(cons #'Exp #'RestExps)))))))
|
||||
((Exp Dots . Rest)
|
||||
(and (zero? depth) (ellipsis? #'Dots))
|
||||
(with-values (destruct Orig #'Exp depth)
|
||||
(syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
|
||||
(if (null? #'(ExpVar ...))
|
||||
(syntax-error Orig "Bad ellipsis")
|
||||
(with-values (destruct Orig #'Rest depth)
|
||||
(syntax-lambda (RestBuilder RestVars RestExps)
|
||||
(with-syntax ((TailExp
|
||||
(if (null? #'RestVars)
|
||||
#''Rest
|
||||
#'RestBuilder))
|
||||
(Orig Orig))
|
||||
(values #'(let f ((ExpVar ExpVar) ...)
|
||||
(if (and (pair? ExpVar) ...)
|
||||
(cons
|
||||
(let ((ExpVar (car ExpVar)) ...)
|
||||
ExpBuilder)
|
||||
(f (cdr ExpVar) ...))
|
||||
(if (and (null? ExpVar) ...)
|
||||
TailExp
|
||||
(error 'unquote
|
||||
"Mismatched lists in ~s"
|
||||
Orig))))
|
||||
(append #'(ExpVar ...) #'RestVars)
|
||||
(append #'(ExpExp ...) #'RestExps)))))))))
|
||||
;; Vectors
|
||||
(#(X ...)
|
||||
(with-values (destruct Orig #'(X ...) depth)
|
||||
(syntax-lambda (LsBuilder LsVars LsExps)
|
||||
(values #'(list->vector LsBuilder) #'LsVars #'LsExps))))
|
||||
;; random stuff
|
||||
((Hd . Tl)
|
||||
(with-values (destruct Orig #'Hd depth)
|
||||
(syntax-lambda (HdBuilder HdVars HdExps)
|
||||
(with-values (destruct Orig #'Tl depth)
|
||||
(syntax-lambda (TlBuilder TlVars TlExps)
|
||||
(with-syntax ((Hd (if (null? #'HdVars)
|
||||
#''Hd
|
||||
#'HdBuilder))
|
||||
(Tl (if (null? #'TlVars)
|
||||
#''Tl
|
||||
#'TlBuilder)))
|
||||
(values #'(cons Hd Tl)
|
||||
(append #'HdVars #'TlVars)
|
||||
(append #'HdExps #'TlExps))))))))
|
||||
(OtherThing
|
||||
(values #''OtherThing '() '())))))
|
||||
;; macro begins
|
||||
(syntax-case x ()
|
||||
((_ Datum)
|
||||
(with-values (destruct #'(quasiquote Datum) #'Datum 0)
|
||||
(syntax-lambda (Builder (Var ...) (Exp ...))
|
||||
(if (null? #'(Var ...))
|
||||
#''Datum
|
||||
#'(let ((Var Exp) ...)
|
||||
Builder))))))))
|
||||
|
||||
(define-syntax extend-backquote
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ Template Exp ...)
|
||||
(with-syntax ((quasiquote
|
||||
(datum->syntax #'Template 'quasiquote)))
|
||||
#'(let-syntax ((quasiquote
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ Foo) #'(my-backquote Foo))))))
|
||||
Exp ...))))))
|
||||
|
||||
;;; ------------------------------
|
||||
|
||||
(define-syntax with-values
|
||||
(syntax-rules ()
|
||||
((_ P C) (call-with-values (lambda () P) C))))
|
||||
|
||||
(define-syntax letcc
|
||||
(syntax-rules ()
|
||||
((_ V B0 B ...) (call/cc (lambda (V) B0 B ...)))))
|
||||
|
||||
(define classify-list
|
||||
(lambda (ls)
|
||||
(cond
|
||||
((null? ls) 'proper)
|
||||
((not (pair? ls)) 'improper)
|
||||
(else
|
||||
(let f ((tortoise ls) (hare (cdr ls)))
|
||||
(cond
|
||||
((eq? tortoise hare) 'infinite)
|
||||
((null? hare) 'proper)
|
||||
((not (pair? hare)) 'improper)
|
||||
(else
|
||||
(let ((hare (cdr hare)))
|
||||
(cond
|
||||
((null? hare) 'proper)
|
||||
((not (pair? hare)) 'improper)
|
||||
(else (f (cdr ls) (cdr hare))))))))))))
|
||||
|
||||
(define ilist-copy-flat
|
||||
(lambda (ils)
|
||||
(let f ((tortoise ils) (hare (cdr ils)))
|
||||
(if (eq? tortoise hare)
|
||||
(list (car tortoise))
|
||||
(cons (car tortoise) (f (cdr tortoise) (cddr hare)))))))
|
||||
|
||||
(define sexp-dispatch
|
||||
(lambda (obj pat);; #f or list of vars
|
||||
(letcc escape
|
||||
(let ((fail (lambda () (escape #f))))
|
||||
(let f ((pat pat) (obj obj) (vals '()))
|
||||
(cond
|
||||
((eq? pat 'any)
|
||||
(cons obj vals))
|
||||
((eq? pat 'each-any)
|
||||
;; handle infinities
|
||||
(case (classify-list obj)
|
||||
((proper infinite) (cons obj vals))
|
||||
((improper) (fail))))
|
||||
((pair? pat)
|
||||
(if (pair? obj)
|
||||
(f (car pat) (car obj) (f (cdr pat) (cdr obj) vals))
|
||||
(fail)))
|
||||
((vector? pat)
|
||||
(case (vector-ref pat 0)
|
||||
((atom)
|
||||
(let ((a (vector-ref pat 1)))
|
||||
(if (eqv? obj a)
|
||||
vals
|
||||
(fail))))
|
||||
((vector)
|
||||
(if (vector? obj)
|
||||
(let ((vec-pat (vector-ref pat 1)))
|
||||
(f vec-pat (vector->list obj) vals))
|
||||
(fail)))
|
||||
((each)
|
||||
;; if infinite, copy the list as flat, then do the matching,
|
||||
;; then do some set-cdrs.
|
||||
(let ((each-pat (vector-ref pat 1))
|
||||
(each-size (vector-ref pat 2)))
|
||||
(case (classify-list obj)
|
||||
((improper) (fail))
|
||||
((infinite)
|
||||
(let ((each-vals (f pat (ilist-copy-flat obj) '())))
|
||||
(for-each (lambda (x) (set-cdr! (last-pair x) x))
|
||||
each-vals)
|
||||
(append each-vals vals)))
|
||||
((proper)
|
||||
(append
|
||||
(let g ((obj obj))
|
||||
(if (null? obj)
|
||||
(make-list each-size '())
|
||||
(let ((hd-vals (f each-pat (car obj) '()))
|
||||
(tl-vals (g (cdr obj))))
|
||||
(map cons hd-vals tl-vals))))
|
||||
vals)))))
|
||||
((tail-each)
|
||||
(let ((each-pat (vector-ref pat 1))
|
||||
(each-size (vector-ref pat 2))
|
||||
(revtail-pat (vector-ref pat 3))
|
||||
(revtail-tail-pat (vector-ref pat 4)))
|
||||
(when (eq? (classify-list obj) 'infinite) (fail))
|
||||
(with-values
|
||||
(let g ((obj obj))
|
||||
;; in-tail?, vals, revtail-left/ls
|
||||
(cond
|
||||
((pair? obj)
|
||||
(with-values (g (cdr obj))
|
||||
(lambda (in-tail? vals tail-left/ls)
|
||||
(if in-tail?
|
||||
(if (null? tail-left/ls)
|
||||
(values #f vals (list (car obj)))
|
||||
(values #t (f (car tail-left/ls)
|
||||
(car obj)
|
||||
vals)
|
||||
(cdr tail-left/ls)))
|
||||
(values #f vals
|
||||
(cons (car obj) tail-left/ls))))))
|
||||
(else
|
||||
(values #t
|
||||
(f revtail-tail-pat obj vals)
|
||||
revtail-pat))))
|
||||
(lambda (in-tail? vals tail-left/ls)
|
||||
(if in-tail?
|
||||
(if (null? tail-left/ls)
|
||||
(append (make-list each-size '())
|
||||
vals)
|
||||
(fail))
|
||||
(f each-pat tail-left/ls vals))))))))
|
||||
(else
|
||||
(if (eqv? obj pat)
|
||||
vals
|
||||
(fail)))))))))
|
||||
)
|
||||
|
||||
|
||||
;;; examples of passing along threaded information.
|
||||
|
||||
;;; Try (collect-symbols '(if (x y 'a 'c zz) 'b 'c))
|
||||
;;; Note that it commonizes the reference to c.
|
||||
|
||||
;; (define-syntax with-values
|
||||
;; (syntax-rules ()
|
||||
;; ((_ P C) (call-with-values (lambda () P) C))))
|
||||
;; (define collect-symbols
|
||||
;; (lambda (exp)
|
||||
;; (with-values (collect-symbols-help exp)
|
||||
;; (lambda (symbol-decls exp)
|
||||
;; (match symbol-decls
|
||||
;; (((,symbol-name . ,symbol-var) ...)
|
||||
;; `(let ((,symbol-var (quote ,symbol-name)) ...) ,exp)))))))
|
||||
;; (define collect-symbols-help
|
||||
;; (lambda (exp)
|
||||
;; (let ((symbol-env '()))
|
||||
;; (match+ (symbol-env) exp
|
||||
;; (,x
|
||||
;; (guard (symbol? x))
|
||||
;; (values symbol-env x))
|
||||
;; ((quote ,x)
|
||||
;; (guard (symbol? x))
|
||||
;; (let ((pair/false (assq x symbol-env)))
|
||||
;; (if pair/false
|
||||
;; (values symbol-env (cdr pair/false))
|
||||
;; (let ((v (gensym)))
|
||||
;; (values (cons (cons x v) symbol-env)
|
||||
;; v)))))
|
||||
;; ((quote ,x)
|
||||
;; (values symbol-env `(quote ,x)))
|
||||
;; ((if ,(t) ,(c) ,(a))
|
||||
;; (values symbol-env `(if ,t ,c ,a)))
|
||||
;; ((,(op) ,(arg) ...)
|
||||
;; (values symbol-env `(,op ,arg ...)))))))
|
||||
;;
|
||||
;; ;;; the grammar for this one is just if-exprs and everything else
|
||||
;;
|
||||
;; (define collect-leaves
|
||||
;; (lambda (exp acc)
|
||||
;; (match+ (acc) exp
|
||||
;; ((if ,() ,() ,())
|
||||
;; acc)
|
||||
;; ((,() ,() ...)
|
||||
;; acc)
|
||||
;; (,x
|
||||
;; (cons x acc)))))
|
||||
;;
|
||||
;; ;; here's something that takes apart quoted stuff.
|
||||
;;
|
||||
;; (define destruct
|
||||
;; (lambda (datum)
|
||||
;; (match datum
|
||||
;; (() `'())
|
||||
;; ((,(X) . ,(Y))`(cons ,X ,Y))
|
||||
;; (#(,(X) ...) `(vector ,X ...))
|
||||
;; (,thing
|
||||
;; (guard (symbol? thing))
|
||||
;; `',thing)
|
||||
;; (,thing
|
||||
;; thing))))
|
||||
;;
|
||||
;; ;; examples using explicit Catas
|
||||
;;
|
||||
;; (define sumsquares
|
||||
;; (lambda (ls)
|
||||
;; (define square
|
||||
;; (lambda (x)
|
||||
;; (* x x)))
|
||||
;; (match ls
|
||||
;; ((,(a*) ...) (apply + a*))
|
||||
;; (,(square -> n) n))))
|
||||
;;
|
||||
;; (define sumsquares
|
||||
;; (lambda (ls)
|
||||
;; (define square
|
||||
;; (lambda (x)
|
||||
;; (* x x)))
|
||||
;; (let ((acc 0))
|
||||
;; (match+ (acc) ls
|
||||
;; ((,() ...) acc)
|
||||
;; (,((lambda (acc x) (+ acc (square x))) ->) acc)))))
|
||||
;;
|
||||
;; ;;; The following uses explicit Catas to parse programs in the
|
||||
;; ;;; simple language defined by the grammar below
|
||||
;;
|
||||
;; ;;; <Prog> -> (program <Stmt>* <Expr>)
|
||||
;; ;;; <Stmt> -> (if <Expr> <Stmt> <Stmt>)
|
||||
;; ;;; | (set! <var> <Expr>)
|
||||
;; ;;; <Expr> -> <var>
|
||||
;; ;;; | <integer>
|
||||
;; ;;; | (if <Expr> <Expr> <Expr>)
|
||||
;; ;;; | (<Expr> <Expr*>)
|
||||
;;
|
||||
;; (define parse
|
||||
;; (lambda (x)
|
||||
;; (define Prog
|
||||
;; (lambda (x)
|
||||
;; (match x
|
||||
;; ((program ,(Stmt -> s*) ... ,(Expr -> e))
|
||||
;; `(begin ,s* ... ,e))
|
||||
;; (,other (error 'parse "invalid program ~s" other)))))
|
||||
;; (define Stmt
|
||||
;; (lambda (x)
|
||||
;; (match x
|
||||
;; ((if ,(Expr -> e) ,(Stmt -> s1) ,(Stmt -> s2))
|
||||
;; `(if ,e ,s1 ,s2))
|
||||
;; ((set! ,v ,(Expr -> e))
|
||||
;; (guard (symbol? v))
|
||||
;; `(set! ,v ,e))
|
||||
;; (,other (error 'parse "invalid statement ~s" other)))))
|
||||
;; (define Expr
|
||||
;; (lambda (x)
|
||||
;; (match x
|
||||
;; (,v (guard (symbol? v)) v)
|
||||
;; (,n (guard (integer? n)) n)
|
||||
;; ((if ,(e1) ,(e2) ,(e3))
|
||||
;; `(if ,e1 ,e2 ,e3))
|
||||
;; ((,(rator) ,(rand*) ...) `(,rator ,rand* ...))
|
||||
;; (,other (error 'parse "invalid expression ~s" other)))))
|
||||
;; (Prog x)))
|
||||
;;; (parse '(program (set! x 3) (+ x 4)))) => (begin (set! x 3) (+ x 4))
|
||||
|
||||
;; CHANGELOG (most recent changes are logged at the top of this file)
|
||||
|
||||
;; (29 Feb 2000)
|
||||
;; Fixed a case sensitivity bug.
|
||||
|
||||
;; (24 Feb 2000)
|
||||
;; Matcher now handles vector patterns. Quasiquote also handles
|
||||
;; vector patterns, but does NOT do the csv6.2 optimization of
|
||||
;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y).
|
||||
;; Also fixed bug in (P ... . P) matching code.
|
||||
|
||||
;; (23 Feb 2000)
|
||||
;; KSM fixed bug in unquote-splicing inside quasiquote.
|
||||
|
||||
;; (10 Feb 2000)
|
||||
;; New forms match+ and trace-match+ thread arguments right-to-left.
|
||||
;; The pattern (P ... . P) now works the way you might expect.
|
||||
;; Infinite lists are now properly matched (and not matched).
|
||||
;; Removed the @ pattern.
|
||||
;; Internal: No longer converting into syntax-case.
|
||||
|
||||
;; (6 Feb 2000)
|
||||
;; Added expansion-time error message for referring to cata variable
|
||||
;; in a guard.
|
||||
|
||||
;; (4 Feb 2000)
|
||||
;; Fixed backquote so it can handle nested backquote (oops).
|
||||
;; Double-backquoted elipses are neutralized just as double-backquoted
|
||||
;; unquotes are. So:
|
||||
;; `(a ,'(1 2 3) ... b) =eval=> (a 1 2 3 b)
|
||||
;; ``(a ,'(1 2 3) ... b) =eval=> `(a ,'(1 2 3) ... b)
|
||||
;; ``(a ,(,(1 2 3) ...) b) =eval=> `(a ,(1 2 3) b)
|
||||
;; Added support for
|
||||
;; `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b))
|
||||
|
||||
;; (1 Feb 2000)
|
||||
;; Fixed a bug involving forgetting to quote stuff in the revised backquote.
|
||||
;; Recognized unquote-splicing and signalled errors in the appropriate places.
|
||||
;; Added support for deep elipses in backquote.
|
||||
;; Rewrote backquote so it does the rebuilding directly instead of
|
||||
;; expanding into Chez's backquote.
|
||||
|
||||
;; (31 Jan 2000)
|
||||
;; Kent Dybvig fixed template bug.
|
||||
|
||||
;; (31 Jan 2000)
|
||||
;; Added the trace-match form, and made guards contain
|
||||
;; an explicit and expression:
|
||||
;; (guard E ...) ==> (guard (and E ...))
|
||||
|
||||
;; (26 Jan 2000)
|
||||
;; Inside the clauses of match expressions, the following
|
||||
;; transformation is performed inside backquote expressions:
|
||||
;; ,v ... ==> ,@v
|
||||
;; (,v ,w) ... ==> ,@(map list v w)
|
||||
;; etc.
|
||||
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
#!/usr/bin/env scheme-script
|
||||
|
||||
(import (ikarus) (match))
|
||||
|
||||
(define (constant? x)
|
||||
(or (number? x) (char? x) (string? x) (boolean? x)))
|
||||
|
||||
(define (ee x)
|
||||
(define (ee x env)
|
||||
(trace-match foo x
|
||||
[,c (guard (constant? c)) c]
|
||||
[,x (guard (symbol? x))
|
||||
(cond
|
||||
((assq x env) => cdr)
|
||||
(else (error 'ee "unbound variable" x)))]
|
||||
;[(let ([,x* ,v*] ...) ,b)
|
||||
; (ee b (append (map cons x* (map (lambda (x) (ee x env)) v*)) env))]
|
||||
[(let ([,x* ,[v*]] ...) ,b)
|
||||
(ee b (append (map cons x* v*) env))]
|
||||
[(+ ,[x] ,[y]) (+ x y)]
|
||||
[,others (error 'ee "invalid expression" others)]))
|
||||
(ee x '()))
|
||||
|
||||
(pretty-print
|
||||
(ee '(let ((x 5)) (let ((y (+ x x))) (+ y x)))))
|
||||
|
||||
;(new-cafe ee)
|
||||
|
||||
Binary file not shown.
|
|
@ -417,7 +417,7 @@
|
|||
(unless (string? str)
|
||||
(error 'open-string-input-port str))
|
||||
($make-port 0 (string-length str) str 0
|
||||
#t
|
||||
#t ;;; transcoder
|
||||
#f ;;; closed?
|
||||
(fxior fast-get-tag fast-get-char-tag)
|
||||
"*string-input-port*"
|
||||
|
|
|
|||
|
|
@ -33,40 +33,43 @@
|
|||
(newline)))
|
||||
|
||||
(define make-traced-procedure
|
||||
(lambda (name proc)
|
||||
(lambda args
|
||||
(call/cf
|
||||
(lambda (f)
|
||||
(cond
|
||||
[(memq f k*) =>
|
||||
(lambda (ls)
|
||||
(display-trace ls (cons name args))
|
||||
(apply proc args))]
|
||||
[else
|
||||
(display-trace (cons 1 k*) (cons name args))
|
||||
(dynamic-wind
|
||||
(lambda () (set! k* (cons f k*)))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(call/cf
|
||||
(lambda (nf)
|
||||
(set! f nf)
|
||||
(set-car! k* nf)
|
||||
(apply proc args))))
|
||||
(lambda v*
|
||||
(display-prefix k* #t)
|
||||
(unless (null? v*)
|
||||
(write (car v*))
|
||||
(let f ([v* (cdr v*)])
|
||||
(cond
|
||||
[(null? v*) (newline)]
|
||||
[else
|
||||
(write-char #\space)
|
||||
(write (car v*))
|
||||
(f (cdr v*))])))
|
||||
(apply values v*))))
|
||||
(lambda () (set! k* (cdr k*))))])))))))
|
||||
(case-lambda
|
||||
[(name proc) (make-traced-procedure name proc (lambda (x) x))]
|
||||
[(name proc filter)
|
||||
(lambda args
|
||||
(call/cf
|
||||
(lambda (f)
|
||||
(cond
|
||||
[(memq f k*) =>
|
||||
(lambda (ls)
|
||||
(display-trace ls (filter (cons name args)))
|
||||
(apply proc args))]
|
||||
[else
|
||||
(display-trace (cons 1 k*) (filter (cons name args)))
|
||||
(dynamic-wind
|
||||
(lambda () (set! k* (cons f k*)))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(call/cf
|
||||
(lambda (nf)
|
||||
(set! f nf)
|
||||
(set-car! k* nf)
|
||||
(apply proc args))))
|
||||
(lambda v*
|
||||
(display-prefix k* #t)
|
||||
(unless (null? v*)
|
||||
(let ([v* (filter v*)])
|
||||
(write (car v*))
|
||||
(let f ([v* (cdr v*)])
|
||||
(cond
|
||||
[(null? v*) (newline)]
|
||||
[else
|
||||
(write-char #\space)
|
||||
(write (car v*))
|
||||
(f (cdr v*))]))))
|
||||
(apply values v*))))
|
||||
(lambda () (set! k* (cdr k*))))]))))])))
|
||||
|
||||
|
||||
#!eof
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1222
|
||||
1223
|
||||
|
|
|
|||
|
|
@ -151,6 +151,7 @@
|
|||
[unsyntax-splicing (macro . unsyntax-splicing)]
|
||||
[trace-lambda (macro . trace-lambda)]
|
||||
[trace-define (macro . trace-define)]
|
||||
[trace-define-syntax (macro . trace-define-syntax)]
|
||||
[guard (macro . guard)]
|
||||
[eol-style (macro . eol-style)]
|
||||
[buffer-mode (macro . buffer-mode)]
|
||||
|
|
@ -270,6 +271,7 @@
|
|||
[time i]
|
||||
[trace-lambda i]
|
||||
[trace-define i]
|
||||
[trace-define-syntax i]
|
||||
[make-list i]
|
||||
[last-pair i]
|
||||
[bwp-object? i]
|
||||
|
|
|
|||
|
|
@ -1115,6 +1115,19 @@
|
|||
"not a procedure" v)))))
|
||||
(stx-error stx "invalid name"))))))
|
||||
|
||||
(define trace-define-syntax-macro
|
||||
(lambda (stx)
|
||||
(syntax-match stx ()
|
||||
((_ who expr)
|
||||
(if (id? who)
|
||||
(bless `(define-syntax ,who
|
||||
(let ((v ,expr))
|
||||
(if (procedure? v)
|
||||
(make-traced-procedure ',who v syntax->datum)
|
||||
(error 'trace-define-syntax
|
||||
"not a procedure" v)))))
|
||||
(stx-error stx "invalid name"))))))
|
||||
|
||||
(define guard-macro
|
||||
(lambda (x)
|
||||
(define (gen-clauses con outerk clause*)
|
||||
|
|
@ -2367,6 +2380,7 @@
|
|||
((define-enumeration) define-enumeration-macro)
|
||||
((trace-lambda) trace-lambda-macro)
|
||||
((trace-define) trace-define-macro)
|
||||
((trace-define-syntax) trace-define-syntax-macro)
|
||||
((define-condition-type) define-condition-type-macro)
|
||||
((include-into) include-into-macro)
|
||||
((eol-style)
|
||||
|
|
|
|||
Loading…
Reference in New Issue