diff --git a/src/ikarus.boot b/src/ikarus.boot index 95e80a8..de7abda 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libcontrol.ss b/src/ikarus.control.ss similarity index 81% rename from src/libcontrol.ss rename to src/ikarus.control.ss index 1db5aad..f1e92c7 100644 --- a/src/libcontrol.ss +++ b/src/ikarus.control.ss @@ -1,27 +1,30 @@ (library (ikarus control) - (export) - (import (scheme)) -;(let () + (export call/cf call/cc dynamic-wind) + (import + (only (scheme) $fp-at-base $current-frame $frame->continuation + $seal-frame-and-call) + (except (ikarus) call/cf call/cc dynamic-wind)) -(let () - (define call-with-current-frame + (define primitive-call/cf (lambda (f) (if ($fp-at-base) (f ($current-frame)) ($seal-frame-and-call f)))) - (primitive-set! 'call/cf call-with-current-frame)) -(let () + (define call/cf + (lambda (f) + (if (procedure? f) + (primitive-call/cf f) + (error 'call/cf "~s is not a procedure" f)))) + (define primitive-call/cc (lambda (f) - (call/cf + (primitive-call/cf (lambda (frm) (f ($frame->continuation frm)))))) - (primitive-set! '$primitive-call/cc primitive-call/cc)) - -(let ([winders '()]) + (define winders '()) (define len (lambda (ls n) @@ -72,7 +75,7 @@ (define call/cc (lambda (f) - ($primitive-call/cc + (primitive-call/cc (lambda (k) (let ([save winders]) (f (case-lambda @@ -94,9 +97,4 @@ [(v1 v2 . v*) (set! winders (cdr winders)) (out) - (apply values v1 v2 v*)])))) - - (primitive-set! 'call/cc call/cc) - (primitive-set! 'dynamic-wind dynamic-wind) - (void)) -) + (apply values v1 v2 v*)]))))) diff --git a/src/makefile.ss b/src/makefile.ss index 25f1c6e..3d46f2b 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -22,7 +22,7 @@ ;;; Error: Error: Error: Error: Error: Error: Error: ...). ;;; '("ikarus.handlers.ss" - "libcontrol.ss" + "ikarus.control.ss" "libcollect.ss" "librecord.ss" "libcxr.ss" @@ -77,9 +77,6 @@ [and (macro . and)] [or (macro . or)])) - (define ikarus-system-primitives - '(print-greeting)) - (define library-legend '([s (ikarus system)] [i (ikarus)] @@ -517,7 +514,6 @@ [fx+-types-error s] [fx+-overflow-error s] [$do-event s] - )) @@ -1057,8 +1053,8 @@ [(assq x ',primlocs) => cdr] [else #f]))) ,@(map build-library library-legend))]) - (parameterize ([print-gensym #f]) - (pretty-print code)) + ;(parameterize ([print-gensym #f]) + ; (pretty-print code)) (let-values ([(code empty-subst empty-env) (boot-library-expand code)]) code))) @@ -1071,7 +1067,7 @@ (lambda (file) (load file (lambda (x) - (pretty-print x) + ; (pretty-print x) (let-values ([(code export-subst export-env) (boot-library-expand x)]) (set! code* (cons code code*)) @@ -1081,6 +1077,7 @@ (printf "building system ...\n") (let-values ([(export-subst export-env export-locs) (make-system-data subst env)]) + (printf "export-subst=~s\n" export-locs) (let ([code (build-system-library export-subst export-env export-locs)]) (values (reverse (list* (car code*) code (cdr code*)))