From 57c54fcb74371276b09c16dc9e7dc4d2909ebab0 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 13 Feb 2016 21:23:04 -0500 Subject: [PATCH] Added letrec* and guard macros --- docs/Scheme-Language-Compliance.md | 2 +- macro-testing.scm | 88 +++++++++++++++--------------- scheme/base.sld | 48 ++++++++++++++++ 3 files changed, 93 insertions(+), 45 deletions(-) diff --git a/docs/Scheme-Language-Compliance.md b/docs/Scheme-Language-Compliance.md index 7f04fdad..60166d7d 100644 --- a/docs/Scheme-Language-Compliance.md +++ b/docs/Scheme-Language-Compliance.md @@ -40,7 +40,7 @@ Section | Status | Comments 6.7 Strings | Partial | No unicode support, `string-ci` functions are not implemented. 6.8 Vectors | Yes | 6.9 Bytevectors | | Not supported yet. -6.10 Control features | Partial | `dynamic-wind` is limited, and does not work across calls to continuations. +6.10 Control features | Yes | `dynamic-wind` is limited, and does not work across calls to continuations. 6.11 Exceptions | Partial | Exceptions are implemented but error objects (and associated functions `error-object`, etc) are not at this time. 6.12 Environments and evaluation | Partial | Only `eval` is implemented at this time. 6.13 Input and output | Partial | Functions do not differentiate between binary and textual ports. Do not have support for input/output strings or bytevectors. diff --git a/macro-testing.scm b/macro-testing.scm index 70896e4a..21168d5b 100644 --- a/macro-testing.scm +++ b/macro-testing.scm @@ -1,50 +1,50 @@ (import (scheme base) (scheme write)) ;(call-with-values (lambda () (values 1 2)) (lambda (x y) (write `(,x ,y)))) -(define-syntax letrec* - (syntax-rules () - ((letrec* ((var val) ...) . body) - (let () (define var val) ... . body)))) - -(define-syntax guard - (syntax-rules () - ((guard (var clause ...) e1 e2 ...) - ((call-with-current-continuation - (lambda (guard-k) - (with-exception-handler - (lambda (condition) - ((call-with-current-continuation - (lambda (handler-k) - (guard-k - (lambda () - (let ((var condition)) ; clauses may SET! var - (guard-aux (handler-k (lambda () - (raise-continuable condition))) - clause ...)))))))) - (lambda () - (let ((res (begin e1 e2 ...))) - (guard-k (lambda () res))))))))))) - -(define-syntax guard-aux - (syntax-rules (else =>) - ((guard-aux reraise (else result1 result2 ...)) - (begin result1 result2 ...)) - ((guard-aux reraise (test => result)) - (let ((temp test)) - (if temp (result temp) reraise))) - ((guard-aux reraise (test => result) clause1 clause2 ...) - (let ((temp test)) - (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) - ((guard-aux reraise (test)) - (or test reraise)) - ((guard-aux reraise (test) clause1 clause2 ...) - (or test (guard-aux reraise clause1 clause2 ...))) - ((guard-aux reraise (test result1 result2 ...)) - (if test (begin result1 result2 ...) reraise)) - ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (guard-aux reraise clause1 clause2 ...))))) +;(define-syntax letrec* +; (syntax-rules () +; ((letrec* ((var val) ...) . body) +; (let () (define var val) ... . body)))) +; +;(define-syntax guard +; (syntax-rules () +; ((guard (var clause ...) e1 e2 ...) +; ((call-with-current-continuation +; (lambda (guard-k) +; (with-exception-handler +; (lambda (condition) +; ((call-with-current-continuation +; (lambda (handler-k) +; (guard-k +; (lambda () +; (let ((var condition)) ; clauses may SET! var +; (guard-aux (handler-k (lambda () +; (raise-continuable condition))) +; clause ...)))))))) +; (lambda () +; (let ((res (begin e1 e2 ...))) +; (guard-k (lambda () res))))))))))) +; +;(define-syntax guard-aux +; (syntax-rules (else =>) +; ((guard-aux reraise (else result1 result2 ...)) +; (begin result1 result2 ...)) +; ((guard-aux reraise (test => result)) +; (let ((temp test)) +; (if temp (result temp) reraise))) +; ((guard-aux reraise (test => result) clause1 clause2 ...) +; (let ((temp test)) +; (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) +; ((guard-aux reraise (test)) +; (or test reraise)) +; ((guard-aux reraise (test) clause1 clause2 ...) +; (or test (guard-aux reraise clause1 clause2 ...))) +; ((guard-aux reraise (test result1 result2 ...)) +; (if test (begin result1 result2 ...) reraise)) +; ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) +; (if test +; (begin result1 result2 ...) +; (guard-aux reraise clause1 clause2 ...))))) (define-syntax %case (syntax-rules () diff --git a/scheme/base.sld b/scheme/base.sld index 80c26086..c0231b35 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -3,6 +3,9 @@ (export cons-source syntax-rules + letrec* + guard + guard-aux ; TODO: need filter for the next two. also, they really belong in SRFI-1, not here ;delete ;delete-duplicates @@ -1281,4 +1284,49 @@ _expr ; (list (rename 'strip-syntactic-closures) _expr) ) #f))))))))))) + +(define-syntax letrec* + (syntax-rules () + ((letrec* ((var val) ...) . body) + (let () (define var val) ... . body)))) + +(define-syntax guard + (syntax-rules () + ((guard (var clause ...) e1 e2 ...) + ((call-with-current-continuation + (lambda (guard-k) + (with-exception-handler + (lambda (condition) + ((call-with-current-continuation + (lambda (handler-k) + (guard-k + (lambda () + (let ((var condition)) ; clauses may SET! var + (guard-aux (handler-k (lambda () + (raise-continuable condition))) + clause ...)))))))) + (lambda () + (let ((res (begin e1 e2 ...))) + (guard-k (lambda () res))))))))))) + +(define-syntax guard-aux + (syntax-rules (else =>) + ((guard-aux reraise (else result1 result2 ...)) + (begin result1 result2 ...)) + ((guard-aux reraise (test => result)) + (let ((temp test)) + (if temp (result temp) reraise))) + ((guard-aux reraise (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test)) + (or test reraise)) + ((guard-aux reraise (test) clause1 clause2 ...) + (or test (guard-aux reraise clause1 clause2 ...))) + ((guard-aux reraise (test result1 result2 ...)) + (if test (begin result1 result2 ...) reraise)) + ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (guard-aux reraise clause1 clause2 ...))))) ))