conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* libcontrol is now a full library. 

renamed:
  src/libcontrol.ss => src/ikarus.control.ss
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 01:56:44 -04:00
parent 28e5c26cee
commit 9a28870d31
3 changed files with 21 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

34
src/libcontrol.ss → src/ikarus.control.ss
View File

@ -1,27 +1,30 @@
(library (ikarus control) (library (ikarus control)
(export) (export call/cf call/cc dynamic-wind)
(import (scheme)) (import
;(let () (only (scheme) $fp-at-base $current-frame $frame->continuation
$seal-frame-and-call)
(except (ikarus) call/cf call/cc dynamic-wind))
(let () (define primitive-call/cf
(define call-with-current-frame
(lambda (f) (lambda (f)
(if ($fp-at-base) (if ($fp-at-base)
(f ($current-frame)) (f ($current-frame))
($seal-frame-and-call f)))) ($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 (define primitive-call/cc
(lambda (f) (lambda (f)
(call/cf (primitive-call/cf
(lambda (frm) (lambda (frm)
(f ($frame->continuation frm)))))) (f ($frame->continuation frm))))))
(primitive-set! '$primitive-call/cc primitive-call/cc))
(define winders '())
(let ([winders '()])
(define len (define len
(lambda (ls n) (lambda (ls n)
@ -72,7 +75,7 @@
(define call/cc (define call/cc
(lambda (f) (lambda (f)
($primitive-call/cc (primitive-call/cc
(lambda (k) (lambda (k)
(let ([save winders]) (let ([save winders])
(f (case-lambda (f (case-lambda
@ -94,9 +97,4 @@
[(v1 v2 . v*) [(v1 v2 . v*)
(set! winders (cdr winders)) (set! winders (cdr winders))
(out) (out)
(apply values v1 v2 v*)])))) (apply values v1 v2 v*)])))))
(primitive-set! 'call/cc call/cc)
(primitive-set! 'dynamic-wind dynamic-wind)
(void))
)

13
src/makefile.ss
View File

@ -22,7 +22,7 @@
;;; Error: Error: Error: Error: Error: Error: Error: ...). ;;; Error: Error: Error: Error: Error: Error: Error: ...).
;;; ;;;
'("ikarus.handlers.ss" '("ikarus.handlers.ss"
"libcontrol.ss" "ikarus.control.ss"
"libcollect.ss" "libcollect.ss"
"librecord.ss" "librecord.ss"
"libcxr.ss" "libcxr.ss"
@ -77,9 +77,6 @@
[and (macro . and)] [and (macro . and)]
[or (macro . or)])) [or (macro . or)]))
(define ikarus-system-primitives
'(print-greeting))
(define library-legend (define library-legend
'([s (ikarus system)] '([s (ikarus system)]
[i (ikarus)] [i (ikarus)]
@ -517,7 +514,6 @@
[fx+-types-error s] [fx+-types-error s]
[fx+-overflow-error s] [fx+-overflow-error s]
[$do-event s] [$do-event s]
)) ))
@ -1057,8 +1053,8 @@
[(assq x ',primlocs) => cdr] [(assq x ',primlocs) => cdr]
[else #f]))) [else #f])))
,@(map build-library library-legend))]) ,@(map build-library library-legend))])
(parameterize ([print-gensym #f]) ;(parameterize ([print-gensym #f])
(pretty-print code)) ; (pretty-print code))
(let-values ([(code empty-subst empty-env) (let-values ([(code empty-subst empty-env)
(boot-library-expand code)]) (boot-library-expand code)])
code))) code)))
@ -1071,7 +1067,7 @@
(lambda (file) (lambda (file)
(load file (load file
(lambda (x) (lambda (x)
(pretty-print x) ; (pretty-print x)
(let-values ([(code export-subst export-env) (let-values ([(code export-subst export-env)
(boot-library-expand x)]) (boot-library-expand x)])
(set! code* (cons code code*)) (set! code* (cons code code*))
@ -1081,6 +1077,7 @@
(printf "building system ...\n") (printf "building system ...\n")
(let-values ([(export-subst export-env export-locs) (let-values ([(export-subst export-env export-locs)
(make-system-data subst env)]) (make-system-data subst env)])
(printf "export-subst=~s\n" export-locs)
(let ([code (build-system-library export-subst export-env export-locs)]) (let ([code (build-system-library export-subst export-env export-locs)])
(values (values
(reverse (list* (car code*) code (cdr code*))) (reverse (list* (car code*) code (cdr code*)))