Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-14 16:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Added letrec* and guard macros

Browse source
This commit is contained in:
Justin Ethier 2016-02-13 21:23:04 -05:00
parent d819885048
commit 57c54fcb74
3 changed files with 93 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
docs/Scheme-Language-Compliance.md
View file

@ -40,7 +40,7 @@ Section | Status | Comments
6.7 Strings | Partial | No unicode support, `string-ci` functions are not implemented. 6.7 Strings | Partial | No unicode support, `string-ci` functions are not implemented.
6.8 Vectors | Yes | 6.8 Vectors | Yes |
6.9 Bytevectors | | Not supported yet. 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.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.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. 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.

88
macro-testing.scm
View file

@ -1,50 +1,50 @@
(import (scheme base) (scheme write)) (import (scheme base) (scheme write))
;(call-with-values (lambda () (values 1 2)) (lambda (x y) (write `(,x ,y)))) ;(call-with-values (lambda () (values 1 2)) (lambda (x y) (write `(,x ,y))))
(define-syntax letrec* ;(define-syntax letrec*
(syntax-rules () ; (syntax-rules ()
((letrec* ((var val) ...) . body) ; ((letrec* ((var val) ...) . body)
(let () (define var val) ... . body)))) ; (let () (define var val) ... . body))))
;
(define-syntax guard ;(define-syntax guard
(syntax-rules () ; (syntax-rules ()
((guard (var clause ...) e1 e2 ...) ; ((guard (var clause ...) e1 e2 ...)
((call-with-current-continuation ; ((call-with-current-continuation
(lambda (guard-k) ; (lambda (guard-k)
(with-exception-handler ; (with-exception-handler
(lambda (condition) ; (lambda (condition)
((call-with-current-continuation ; ((call-with-current-continuation
(lambda (handler-k) ; (lambda (handler-k)
(guard-k ; (guard-k
(lambda () ; (lambda ()
(let ((var condition)) ; clauses may SET! var ; (let ((var condition)) ; clauses may SET! var
(guard-aux (handler-k (lambda () ; (guard-aux (handler-k (lambda ()
(raise-continuable condition))) ; (raise-continuable condition)))
clause ...)))))))) ; clause ...))))))))
(lambda () ; (lambda ()
(let ((res (begin e1 e2 ...))) ; (let ((res (begin e1 e2 ...)))
(guard-k (lambda () res))))))))))) ; (guard-k (lambda () res)))))))))))
;
(define-syntax guard-aux ;(define-syntax guard-aux
(syntax-rules (else =>) ; (syntax-rules (else =>)
((guard-aux reraise (else result1 result2 ...)) ; ((guard-aux reraise (else result1 result2 ...))
(begin result1 result2 ...)) ; (begin result1 result2 ...))
((guard-aux reraise (test => result)) ; ((guard-aux reraise (test => result))
(let ((temp test)) ; (let ((temp test))
(if temp (result temp) reraise))) ; (if temp (result temp) reraise)))
((guard-aux reraise (test => result) clause1 clause2 ...) ; ((guard-aux reraise (test => result) clause1 clause2 ...)
(let ((temp test)) ; (let ((temp test))
(if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) ; (if temp (result temp) (guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test)) ; ((guard-aux reraise (test))
(or test reraise)) ; (or test reraise))
((guard-aux reraise (test) clause1 clause2 ...) ; ((guard-aux reraise (test) clause1 clause2 ...)
(or test (guard-aux reraise clause1 clause2 ...))) ; (or test (guard-aux reraise clause1 clause2 ...)))
((guard-aux reraise (test result1 result2 ...)) ; ((guard-aux reraise (test result1 result2 ...))
(if test (begin result1 result2 ...) reraise)) ; (if test (begin result1 result2 ...) reraise))
((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) ; ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
(if test ; (if test
(begin result1 result2 ...) ; (begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...))))) ; (guard-aux reraise clause1 clause2 ...)))))
(define-syntax %case (define-syntax %case
(syntax-rules () (syntax-rules ()

48
scheme/base.sld
View file

@ -3,6 +3,9 @@
(export (export
cons-source cons-source
syntax-rules syntax-rules
letrec*
guard
guard-aux
; TODO: need filter for the next two. also, they really belong in SRFI-1, not here ; TODO: need filter for the next two. also, they really belong in SRFI-1, not here
;delete ;delete
;delete-duplicates ;delete-duplicates
@ -1281,4 +1284,49 @@
_expr ; (list (rename 'strip-syntactic-closures) _expr) _expr ; (list (rename 'strip-syntactic-closures) _expr)
) )
#f))))))))))) #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 ...)))))
)) ))