* Ikarus now handles interrupts (e.g. ^C) by signalling an error

when an interrupt occurs.

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;
 }
 

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){

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)

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

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)))))
+
 

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 

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