You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
282 lines
11 KiB
Scheme
282 lines
11 KiB
Scheme
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
|
|
;;; See the accompanying file Copyright for details
|
|
|
|
;;; AWK - TODO - Once the meta-parser can handle language passes that match
|
|
;;; a single variable.
|
|
;;; FIXME - For Ikarus, I needed to use "dots" instead of the ".."
|
|
;;; because Ikarus sees .. as a syntax error, even when it is
|
|
;;; exported as an auxiliary keyword.
|
|
|
|
;;; Time-stamp: <2000-01-10 12:29:38 kemillik>
|
|
;;; (time-stamp generated by emacs: Type M-x time-stamp anywhere to update)
|
|
|
|
;;; syncase is a pattern matcher where patterns are quoted or
|
|
;;; quasiquoted expressions, or symbols. Unquoted symbols denote
|
|
;;; pattern variables. All quoted things must match precisely.
|
|
;;; Also, there is a symbol ".." that may be used to allow repetitions
|
|
;;; of the preceeding pattern. Any pattern variables within are bound
|
|
;;; to a list of matches. ".." may be nested.
|
|
;;; Below is the canonical example of "let"
|
|
|
|
;;; [`(let ([,var ,rhs] ..) ,body0 ,body1 ..)
|
|
;;; (guard (for-all symbol? var) (no-duplicates? var))
|
|
;;; `((lambda ,var ,body0 ,@body1) ,@rhs)]
|
|
|
|
;;; For the pattern to match, the optional guard requires its
|
|
;;; arguments to be true. The guard also uses the pattern
|
|
;;; variables.
|
|
|
|
;;; We have added three obvious new forms: synlambda, synlet, and
|
|
;;; synlet*. Finally, we have added a very useful operation,
|
|
;;; make-double-collector-over-list, whose description follows from the
|
|
;;; very simple code below.
|
|
;;; Here are some descriptive examples of each of the new special forms.
|
|
|
|
;;;> (define foo
|
|
;;; (synlambda `((if ,exp0 ,exp1) ,env)
|
|
;;; (guard (number? exp1))
|
|
;;; `(,env (if ,exp0 ,exp1 0))))
|
|
;;;> (foo '(if 1 2) 'anenv)
|
|
;;;(anenv (if 1 2 0))
|
|
|
|
;;;> (synlet ([`(if ,exp0 ,exp1)
|
|
;;; (guard (number? exp0))
|
|
;;; '(if 0 1)])
|
|
;;; `(if ,exp1, exp0))
|
|
;;;(if 1 0)
|
|
|
|
;;;> (synlet ([`(if ,x ,y ,z) '(if 1 2 3)]
|
|
;;; [`(if ,a then ,b else ,c) '(if 1 then 2 else 3)]
|
|
;;; [`(when ,u ,w) (guard (number? u) (number? w) (= u w))
|
|
;;; '(when 1 1)])
|
|
;;; (list x y z a b c a b))
|
|
;;; (1 2 3 1 2 3 1 2)
|
|
|
|
;;;> (synlet* ([`(if ,exp0 ,exp1) (guard (number? exp0)) '(if 0 1)]
|
|
;;; [`(if ,x ,y ,exp2) `(if ,exp0 ,exp1 5)])
|
|
;;; `(if ,exp0 ,y ,exp2))
|
|
;;;(if 0 1 5)
|
|
|
|
(library (tests synforms)
|
|
(export syncase)
|
|
(import (rnrs))
|
|
|
|
(define-syntax syncase
|
|
(syntax-rules ()
|
|
[(_ Exp (Clause ...) ...)
|
|
(let ([x Exp])
|
|
(call/cc
|
|
(lambda (succeed)
|
|
(pm:c start x succeed Clause ...)
|
|
...
|
|
(error 'syncase "No match for ~s" x))))]))
|
|
|
|
(define-syntax pm:c
|
|
(syntax-rules (guard start finish)
|
|
[(pm:c start V Succ Pattern (guard Exp ...) Body0 Body ...)
|
|
(pm:parse start Pattern
|
|
(pm:c finish V
|
|
(when (and Exp ...)
|
|
(Succ (begin Body0 Body ...)))))]
|
|
[(pm:c finish V Body Pattern UsedFormals)
|
|
(pm:find-dup UsedFormals
|
|
(cont (Dup)
|
|
(pm:error "Duplicate patvar ~s in pattern ~s" Dup Pattern))
|
|
(cont () (pm V Pattern Body)))]
|
|
[(_ start V Succ Pattern Body0 Body ...)
|
|
(pm:c start V Succ Pattern (guard) Body0 Body ...)]
|
|
[(_ start V Succ Pattern)
|
|
(pm:error "Missing body for pattern ~s" Pattern)]))
|
|
|
|
(define-syntax pm:parse ;; returns parsed thing + used formals
|
|
(syntax-rules (dots quasiquote quote unquote start)
|
|
[(pm:parse start () K) (pm:ak K (null) ())]
|
|
[(pm:parse start (unquote X) K) (pm:ak K (formal X) (X))]
|
|
[(pm:parse start (A . D) K) (pm:parseqq start (A . D) K)]
|
|
[(pm:parse start X K) (pm:ak K (keyword X) ())]))
|
|
|
|
(define-syntax pm:parseqq;; returns parsed thing + used formals
|
|
(lambda (x)
|
|
(syntax-case x (unquote start dothead dottail dottemps pairhead pairtail)
|
|
[(pm:parseqq start (unquote ()) K) #'(pm:error "Bad variable: ~s" ())]
|
|
[(pm:parseqq start (unquote (quasiquote X)) K) #'(pm:parseqq start X K)]
|
|
[(pm:parseqq start (unquote (X . Y)) K)
|
|
#'(pm:error "Bad variable: ~s" (X . Y))]
|
|
[(pm:parseqq start (unquote #(X ...)) K)
|
|
#'(pm:error "Bad variable: ~s" #(X ...))]
|
|
[(pm:parseqq start (unquote X) K) #'(pm:ak K (formal X) (X))]
|
|
[(pm:parseqq start (X dots . Y) K)
|
|
(eq? (syntax->datum #'dots) '...)
|
|
#'(pm:parseqq start X (pm:parseqq dothead Y K))]
|
|
[(pm:parseqq dothead Y K Xpat Xformals)
|
|
#'(pm:parseqq^ start Y () ()
|
|
(pm:parseqq dottail Xpat Xformals K))]
|
|
[(pm:parseqq dottail Xpat Xformals K Yrevpat Yformals)
|
|
#'(pm:gen-temps Xformals ()
|
|
(pm:parseqq dottemps Xpat Yrevpat Xformals Yformals K))]
|
|
[(pm:parseqq dottemps Xpat Yrevpat (Xformal ...) (Yformal ...) K Xtemps)
|
|
#'(pm:ak K (dots (Xformal ...) Xtemps Xpat Yrevpat)
|
|
(Xformal ... Yformal ...))]
|
|
[(pm:parseqq start (X . Y) K)
|
|
#'(pm:parseqq start X (pm:parseqq pairhead Y K))]
|
|
[(pm:parseqq pairhead Y K Xpat Xformals)
|
|
#'(pm:parseqq start Y (pm:parseqq pairtail Xpat Xformals K))]
|
|
[(pm:parseqq pairtail Xpat (Xformal ...) K Ypat (Yformal ...))
|
|
#'(pm:ak K (pair Xpat Ypat) (Xformal ... Yformal ...))]
|
|
[(pm:parseqq start X K) #'(pm:ak K (keyword X) ())])))
|
|
|
|
(define-syntax pm:parseqq^;; returns list-of parsed thing + used formals
|
|
(syntax-rules (dots start pairhead)
|
|
[(pm:parseqq^ start () Acc Used K) (pm:ak K Acc ())]
|
|
[(pm:parseqq^ start (dots . Y) Acc Used K)
|
|
(pm:error "Illegal continuation of list pattern beyond dots: ~s" Y)]
|
|
[(pm:parseqq^ start (X . Y) Acc Used K)
|
|
(pm:parseqq start X (pm:parseqq^ pairhead Y Acc Used K))]
|
|
[(pm:parseqq^ pairhead Y Acc (Used ...) K Xpat (Xformal ...))
|
|
(pm:parseqq^ start Y (Xpat . Acc) (Used ... Xformal ...) K)]
|
|
[(pm:parseqq^ start X Acc Used K) (pm:error "Bad pattern ~s" X)]))
|
|
|
|
(define-syntax pm
|
|
(syntax-rules (keyword formal dots null pair)
|
|
[(pm V (keyword K) Body) (when (eqv? V 'K) Body)]
|
|
[(pm V (formal F) Body) (let ((F V)) Body)]
|
|
[(pm V (dots Dformals DTemps DPat (PostPat ...)) Body)
|
|
(when (list? V)
|
|
(let ((rev (reverse V)))
|
|
(pm:help rev (PostPat ...) Dformals DTemps DPat Body)))]
|
|
[(pm V (null) Body) (when (null? V) Body)]
|
|
[(pm V (pair P0 P1) Body)
|
|
(when (pair? V)
|
|
(let ((X (car V)) (Y (cdr V)))
|
|
(pm X P0 (pm Y P1 Body))))]))
|
|
|
|
(define-syntax pm:help
|
|
(syntax-rules ()
|
|
[(pm:help V () (DFormal ...) (DTemp ...) DPat Body)
|
|
(let f ((ls V) (DTemp '()) ...)
|
|
(if (null? ls)
|
|
(let ((DFormal DTemp) ...) Body)
|
|
(let ((X (car ls)) (Y (cdr ls)))
|
|
(pm X DPat
|
|
(f Y (cons DFormal DTemp) ...)))))]
|
|
[(pm:help V (Post0 PostPat ...) DFormals DTemps DPat Body)
|
|
(when (pair? V)
|
|
(let ((X (car V)) (Y (cdr V)))
|
|
(pm X Post0
|
|
(pm:help Y (PostPat ...) DFormals DTemps DPat Body))))]))
|
|
|
|
(define-syntax pm:error
|
|
(syntax-rules ()
|
|
[(pm:error X ...) (error 'syncase 'X ...)]))
|
|
|
|
(define-syntax pm:eq?
|
|
(syntax-rules ()
|
|
[(_ A B SK FK) ; b should be an identifier
|
|
(let-syntax ([f (syntax-rules (B)
|
|
[(f B _SK _FK) (pm:ak _SK)]
|
|
[(f nonB _SK _FK) (pm:ak _FK)])])
|
|
(f A SK FK))]))
|
|
|
|
(define-syntax pm:member?
|
|
(syntax-rules ()
|
|
[(pm:member? A () SK FK) (pm:ak FK)]
|
|
[(pm:member? A (Id0 . Ids) SK FK)
|
|
(pm:eq? A Id0 SK (cont () (pm:member? A Ids SK FK)))]))
|
|
|
|
(define-syntax pm:find-dup
|
|
(syntax-rules ()
|
|
[(pm:find-dup () SK FK) (pm:ak FK)]
|
|
[(pm:find-dup (X . Y) SK FK)
|
|
(pm:member? X Y
|
|
(cont () (pm:ak SK X)) (cont () (pm:find-dup Y SK FK)))]))
|
|
|
|
(define-syntax pm:gen-temps
|
|
(syntax-rules ()
|
|
[(_ () Acc K) (pm:ak K Acc)]
|
|
[(_ (X . Y) Acc K) (pm:gen-temps Y (temp . Acc) K)]))
|
|
|
|
;;; ------------------------------
|
|
;;; Continuation representation and stuff
|
|
(define-syntax cont ; broken for non-nullary case
|
|
(syntax-rules ()
|
|
[(_ () Body) Body]
|
|
[(_ (Var ...) Body Exp ...)
|
|
(let-syntax ([f (syntax-rules ()
|
|
[(_ Var ...) Body])])
|
|
(f Exp ...))]))
|
|
|
|
(define-syntax pm:ak
|
|
(syntax-rules ()
|
|
[(_ (X Y ...) Z ...) (X Y ... Z ...)]))
|
|
|
|
;;; ------------------------------
|
|
;;; tests
|
|
|
|
;(define exp0
|
|
; '(syncase '((a) (b) (c d))
|
|
; ((,zz ,ww) ((,zz .. ,ww) ..)
|
|
; zz)))
|
|
|
|
;(define test
|
|
; (lambda (x)
|
|
; (pretty-print x)
|
|
; (pretty-print (eval x))
|
|
; (newline)))
|
|
;
|
|
;(define test0 (lambda () (test exp0)))
|
|
|
|
;;; There are three additional special forms, which should be obvious.
|
|
(define-syntax synlambda
|
|
(syntax-rules (guard)
|
|
[(_ pat (guard g ...) body0 body1 ...)
|
|
(lambda (x)
|
|
(syncase x
|
|
[pat (guard g ...) (begin body0 body1 ...)]))]
|
|
[(_ pat body0 body1 ...)
|
|
(lambda (x)
|
|
(syncase x
|
|
[pat (begin body0 body1 ...)]))]))
|
|
|
|
(define-syntax synlet
|
|
(syntax-rules (guard)
|
|
[(_ ([pat (guard g) rhs] ...) body0 body1 ...)
|
|
((synlambda `(,pat ...)
|
|
(guard (and g ...)) body0 body1 ...) `(,rhs ...))]
|
|
[(_ ([pat rhs] ...) body0 body1 ...)
|
|
((synlambda `(,pat ...) body0 body1 ...) `(,rhs ...))]
|
|
[(_ stuff ...) (synlet-all-guarded () stuff ...)]))
|
|
|
|
(define-syntax synlet-all-guarded
|
|
(syntax-rules (guard)
|
|
[(_ (x ...) () body0 body1 ...) (synlet (x ...) body0 body1 ...)]
|
|
[(_ (x ...) ([pat (guard g0 g1 g2 ...) rhs] decl ...) body0 body1 ...)
|
|
(synlet-all-guarded (x ... [pat (guard (and g0 g1 g2 ...)) rhs])
|
|
(decl ...) body0 body1 ...)]
|
|
[(_ (x ...) ([pat rhs] decl ...) body0 body1 ...)
|
|
(synlet-all-guarded (x ... [pat (guard #t) rhs])
|
|
(decl ...) body0 body1 ...)]
|
|
[(_ (x ...) ([pat] decl ...) body0 body1 ...)
|
|
(pm:error "synlet missing right-hand-side for pattern: ~s" pat)]
|
|
[(_ () (decl ...)) (pm:error "synlet missing body")]))
|
|
|
|
(define-syntax synlet*
|
|
(syntax-rules ()
|
|
[(_ (dec) body0 body1 ...) (synlet (dec) body0 body1 ...)]
|
|
[(_ (dec0 decl ...) body0 body1 ...)
|
|
(synlet (dec0) (synlet* (decl ...) body0 body1 ...))]))
|
|
|
|
(define make-double-collector-over-list
|
|
(lambda (constructor1 base1 constructor2 base2)
|
|
(letrec ((loop42 (lambda args
|
|
(if (not (= (length args) 2))
|
|
(error 'syncase "Invalid rhs expression"))
|
|
(let ([f (car args)] [arg (cadr args)])
|
|
(cond
|
|
[(null? arg) `(,base1 ,base2)]
|
|
[else
|
|
(synlet ([`(,x ,y) (f (car arg))]
|
|
[`(,x* ,y*) (loop42 f (cdr arg))])
|
|
`(,(constructor1 x x*)
|
|
,(constructor2 y y*)))])))))
|
|
loop42))))
|