diff --git a/CHANGELOG.md b/CHANGELOG.md index dde74ad4..0c66141a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## 0.11.9 - TBD + +Features + +- Added `define-values` from R7RS. + ## 0.11.8 - December 30, 2019 Features diff --git a/scheme/base.sld b/scheme/base.sld index 52905e7b..10d11bf6 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -162,6 +162,7 @@ letrec let*-values let-values + define-values begin case cond @@ -203,13 +204,6 @@ ; rationalize ; ; ;; syntax-rules -; define-values -; -; unclassified TODO's: -; import -; include -; let-syntax -; letrec-syntax ;;;; ) (inline @@ -2025,4 +2019,42 @@ (,(rename 'vector) ,@make-fields)))) ))))) + +(define-syntax define-values + (syntax-rules () + ((define-values () expr) + (define dummy + (call-with-values (lambda () expr) + (lambda args #f)))) + ((define-values (var) expr) + (define var expr)) + ((define-values (var0 var1 ... varn) expr) + (begin + (define var0 + (call-with-values (lambda () expr) list)) + (define var1 + (let ((v (cadr var0))) + (set-cdr! var0 (cddr var0)) + v)) + ... + (define varn + (let ((v (cadr var0))) + (set! var0 (car var0)) + v)))) + ;((define-values (var0 var1 ... . var-dot) expr) + ; (begin + ; (define var0 + ; (call-with-values (lambda () expr) list)) + ; (define var1 + ; (let ((v (cadr var0))) + ; (set-cdr! var0 (cddr var0)) + ; v)) + ; ... + ; (define var-dot + ; (let ((v (cdr var0))) + ; (set! var0 (car var0)) + ; v)))) + ((define-values var expr) + (define var + (call-with-values (lambda () expr) list))))) ))