From: Chris Hanson Date: Wed, 16 May 2018 05:32:46 +0000 (-0700) Subject: Implement GUARD for R7RS. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~36 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ac50ddfe81fe7b763c9b6276c7b096b02311f5eb;p=mit-scheme.git Implement GUARD for R7RS. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 603a96d3c..c98cbdb0d 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -252,9 +252,7 @@ USA. (delay (scons-rule `((* ,cond-clause-pattern) - (or (subform (ignore-if id=? else) - (+ any)) - (value #f))) + ,cond-else-clause-pattern) (lambda (clauses else-actions) (fold-right expand-cond-clause (if else-actions @@ -271,7 +269,15 @@ USA. (cons (value begin) (* any)))))) +(define cond-else-clause-pattern + '(or (subform (ignore-if id=? else) + (+ any)) + (value #f))) + (define (expand-cond-clause clause rest) + ((cond-clause-expander scons-if) clause rest)) + +(define ((cond-clause-expander scons-if) clause rest) (let ((predicate (car clause)) (type (cadr clause)) (actions (cddr clause))) @@ -287,7 +293,9 @@ USA. (scons-if predicate (apply scons-begin actions) rest) - (scons-or predicate rest))) + (let ((temp (new-identifier 'temp))) + (scons-let (list (list temp predicate)) + (scons-if temp temp rest))))) (else (error "Unknown clause type:" type))))) @@ -387,6 +395,36 @@ USA. ((unless condition form ...) (if (not condition) (begin form ...))))) + +(define $guard + (spar-transformer->runtime + (delay + (scons-rule `((subform id + (* ,cond-clause-pattern) + ,cond-else-clause-pattern) + (+ any)) + (lambda (var clauses else-actions body) + (let ((guard-k (new-identifier 'guard-k)) + (condition (new-identifier 'condition))) + (scons-call 'call-with-current-continuation + (scons-lambda (list guard-k) + (scons-call 'with-exception-handler + (scons-lambda (list condition) + (scons-let (list (list var condition)) + (guard-handler guard-k condition clauses else-actions))) + (apply scons-lambda '() body)))))))))) + +(define (guard-handler guard-k condition clauses else-actions) + (if else-actions + (scons-call guard-k + (fold-right expand-cond-clause + (apply scons-begin else-actions) + clauses)) + (fold-right (cond-clause-expander + (lambda (p c a) + (scons-if p (scons-call guard-k c) a))) + (scons-call 'raise-continuable condition) + clauses))) ;;;; Quasiquote diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b50141fcf..b1361360a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4760,6 +4760,7 @@ USA. (define-record-type $define-record-type) (do $do) ;R7RS (fluid-let $fluid-let) + (guard $guard) ;R7RS (let $let) ;R7RS (let* $let*) ;R7RS (let*-syntax $let*-syntax) ;R7RS