diff --git a/cyclone.scm b/cyclone.scm index 100e7fb8..71c5565f 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -151,17 +151,22 @@ input-program))) (cond ((and library? (equal? lib-name '(scheme base))) - (set! globals (append '(call-with-values call/cc) globals)) - (set! module-globals (append '(call-with-values call/cc) module-globals)) + (set! globals (append '(call/cc) globals)) + (set! module-globals (append '(call/cc) module-globals)) (set! input-program - (cons - ;; Experimental version of call-with-values, - ;; seems OK in compiler but not in eval. - '(define call-with-values - (lambda (k producer consumer) - (producer - (lambda (result) - (consumer k result))))) + ;(cons + ; ;; Experimental version of call-with-values, + ; ;; seems OK in compiler but not in eval. + ; '(define call-with-values + ; (lambda (k producer consumer) + ; (let ((x (producer))) + ; (if (and (pair? x) (equal? '(multiple values) (car x))) + ; (apply consumer (cdr x)) + ; (consumer k x)))) + ; ; (producer + ; ; (lambda (result) + ; ; (consumer k result)))) + ; ) ;; multiple args requires more than just this. ;; may want to look at: ;; http://stackoverflow.com/questions/16674214/how-to-implement-call-with-values-to-match-the-values-example-in-r5rs @@ -173,7 +178,7 @@ ;; TODO: will this cause issues if another var is assigned to call/cc? '(define call/cc (lambda (k f) (f k (lambda (_ result) (k result))))) - cps)))) + cps)));) (else ;; No need for call/cc yet (set! input-program cps)))) diff --git a/scheme/base.sld b/scheme/base.sld index fd47814d..5055bc03 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -314,19 +314,36 @@ ;; TODO: The whitespace characters are space, tab, line feed, form feed (not in parser yet), and carriage return. (define call-with-current-continuation call/cc) ;; TODO: this is from r7rs, but is not really good enough by itself - (define (values . things) - (call/cc - (lambda (cont) (apply cont things)))) + ;(define (values . things) + ; (call/cc + ; (lambda (cont) (apply cont things)))) + (define values + (lambda args + (if (and (not (null? args)) (null? (cdr args))) + (car args) + (cons (cons 'multiple 'values) args)))) ;; TODO: just need something good enough for bootstrapping (for now) ;; does not have to be perfect (this is not, does not handle call/cc or exceptions) +; (define call-with-values +; (lambda (producer consumer) +; (let ((x (producer))) +; (if ;(magic? x) +; (and (pair? x) (equal? (car x) (cons 'multiple 'values))) +; (apply consumer (cdr x)) +; (consumer x))))) + (define (dynamic-wind before thunk after) (before) - (call-with-values - thunk - (lambda (result) ;results - (after) - result))) + (let ((result (thunk))) + (after) + result) + ;(call-with-values + ; thunk + ; (lambda (result) ;results + ; (after) + ; result))) ;(apply values results)))) + ) (define (call-with-port port proc) (let ((result (proc port))) (close-port port) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 04698f9b..9f1c8ebf 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -136,7 +136,7 @@ (define *defined-macros* (list)) (define (built-in-syms) - '(call-with-values call/cc define)) + '(call/cc define)) ;; Tuning (define *do-code-gen* #t) ; Generate C code? diff --git a/scheme/eval.sld b/scheme/eval.sld index d57c07dc..5758edf9 100644 --- a/scheme/eval.sld +++ b/scheme/eval.sld @@ -131,7 +131,6 @@ (define primitive-procedures (list (list 'call/cc call/cc) - (list 'call-with-values call-with-values) (list 'Cyc-global-vars Cyc-global-vars) (list 'Cyc-get-cvar Cyc-get-cvar) (list 'Cyc-set-cvar! Cyc-set-cvar!)