diff --git a/bin/ikarus b/bin/ikarus index b8a0e54..e2e32bd 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-main.c b/bin/ikarus-main.c index 0e21c21..716a2fe 100644 --- a/bin/ikarus-main.c +++ b/bin/ikarus-main.c @@ -184,7 +184,7 @@ int main(int argc, char** argv){ #endif void handler(int signo, struct __siginfo* info, ucontext_t* uap){ - the_pcb->engine_counter = 1; + the_pcb->engine_counter = -1; the_pcb->interrupted = 1; } diff --git a/bin/ikarus-runtime.c b/bin/ikarus-runtime.c index a8f11ca..1938d61 100644 --- a/bin/ikarus-runtime.c +++ b/bin/ikarus-runtime.c @@ -759,13 +759,26 @@ ikrt_close_file(ikp fd, ikpcb* pcb){ ikp ikrt_read(ikp fd, ikp buff, ikpcb* pcb){ - int bytes = read(unfix(fd), string_data(buff), unfix(ref(buff, off_string_length))); + int bytes = + read(unfix(fd), string_data(buff), unfix(ref(buff, off_string_length))); + ikp fbytes = fix(bytes); + if (bytes == unfix(fbytes)){ + return fbytes; + } else { + fprintf(stderr, "ERR: ikrt_read: too big\n"); + exit(-1); + } +} + +#if 0 if(bytes == -1){ + fprintf(stderr, "ERR=%s (%d)\n", strerror(errno), errno); return false_object; } else { return fix(bytes); } } +#endif ikp ikrt_open_input_file(ikp fname, ikpcb* pcb){ diff --git a/src/ikarus.boot b/src/ikarus.boot index a506169..5f17e8e 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libchezio.ss b/src/libchezio.ss index eef75fb..d17d46e 100644 --- a/src/libchezio.ss +++ b/src/libchezio.ss @@ -414,16 +414,18 @@ ($string-ref ($port-input-buffer p) idx)) (if open? (let ([bytes - (foreign-call "ikrt_read" fd - ($port-input-buffer p))]) + (foreign-call "ikrt_read" + fd ($port-input-buffer p))]) + ;($do-event) (cond - [(not bytes) - (error 'read-char "Cannot read from ~s" port-name)] + [($fx> bytes 0) + ($set-port-input-size! p bytes) + ($read-char p)] [($fx= bytes 0) (eof-object)] [else - ($set-port-input-size! p bytes) - ($read-char p)])) + (error 'read-char "Cannot read from ~a" + port-name)])) (error 'read-char "port ~s is closed" p))))] [(peek-char p) (unless (input-port? p) diff --git a/src/libcompile.ss b/src/libcompile.ss index c9ad6a1..31631dc 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -176,6 +176,8 @@ [$arg-list 0 value] [$seal-frame-and-call 1 tail] [$frame->continuation 1 value] + [$interrupted? 0 pred] + [$unset-interrupted! 0 effect] ;;; ;;; records ;;; @@ -2390,7 +2392,7 @@ (make-seq (make-interrupt-call (make-primcall '$engine-check '()) - (make-funcall (make-primref '$engine-expired) '())) + (make-funcall (make-primref '$do-event) '())) x)) (define (CaseExpr x) (record-case x @@ -2964,6 +2966,7 @@ [(dirty-vector) (mem 28 pcr)] [(arg-list) (mem 32 pcr)] [(engine-counter) (mem 36 pcr)] + [(interrupted) (mem 40 pcr)] [else (error 'pcb-ref "invalid arg ~s" x)]))) (define (primref-loc op) @@ -2994,7 +2997,10 @@ [else (obj x)])) (define (cond-branch op Lt Lf ac) (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) + (cond + [(assq x '([je jne] [jne je] [jl jge] [jle jg] [jg jle] [jge jl])) + => cadr] + [else (error who "BUG: no opposite of ~s" x)])) (unless (or Lt Lf) (error 'cond-branch "no labels")) (cond @@ -3211,6 +3217,10 @@ (subl (int wordsize) eax) (cmpl eax fpr) (cond-branch 'je Lt Lf ac))] + [($interrupted?) + (list* (movl (pcb-ref 'interrupted) eax) + (cmpl (int 0) eax) + (cond-branch 'jne Lt Lf ac))] [($fp-overflow) (list* (cmpl (pcb-ref 'frame-redline) fpr) (cond-branch 'jle Lt Lf ac))] @@ -4059,6 +4069,9 @@ (addl (pcb-ref 'dirty-vector) ebx) (movl (int dirty-word) (mem 0 ebx)) ac)] + [($unset-interrupted!) + (list* (movl (int 0) (pcb-ref 'interrupted)) + ac)] [(cons pair? void $fxadd1 $fxsub1 $record-ref $fx=) (let f ([arg* arg*]) (cond diff --git a/src/libhandlers.ss b/src/libhandlers.ss index e00c08d..9686091 100644 --- a/src/libhandlers.ss +++ b/src/libhandlers.ss @@ -72,7 +72,12 @@ (lambda (x y) (error 'fx+ "overflow"))) -(primitive-set! '$engine-expired +(primitive-set! '$do-event (lambda () - (display "Engine Expired\n" (console-output-port)))) + (if ($interrupted?) + (begin + ($unset-interrupted!) + (error #f "Interrupted")) + (display "Engine Expired\n" (console-output-port))))) + diff --git a/src/libinterpret.ss b/src/libinterpret.ss index f064d7b..1185006 100644 --- a/src/libinterpret.ss +++ b/src/libinterpret.ss @@ -304,11 +304,11 @@ ))] [else (syntax-error x)]))) ;;; - (primitive-set! 'interpret - (lambda (x) - (let ([x (expand x)]) - (let ([p (C x '())]) - (p '()))))) + ;(primitive-set! 'interpret + ; (lambda (x) + ; (let ([x (expand x)]) + ; (let ([p (C x '())]) + ; (p '()))))) ;;; (primitive-set! 'current-eval (make-parameter diff --git a/src/makefile.ss b/src/makefile.ss index eb66fdc..230311e 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -114,7 +114,7 @@ $set-tcbucket-dlink-prev! $set-tcbucket-dlink-next! call/cf trace-symbol! untrace-symbol! make-traced-procedure fixnum->string - + $interrupted? $unset-interrupted! $do-event ;;; TODO: must open-code $make-port/input $make-port/output $make-port/both