0
@@ -437,23 +437,62 @@
0
   ;  (addl (imm si) esp)
0
   ;  (jmp '__type_error)
0
   ;  (label cont-label)))
0
-  (addl (imm si) esp)
0
+  (addl (imm (+ si wordsize)) esp)
0
   (call (make-string "__check_" name))
0
-  (subl (imm si) esp))
0
-
0
-(def emit-static-type-check-routine (name mask tag)
0
+  (subl (imm (+ si wordsize)) esp))
0
+
0
+(def emit-get-tag (src dest-reg tmp-reg)
0
+  ; get the tag of the object pointed by the register src
0
+  ; put tag in dest-reg
0
+  (let cont (unique-label) ; label to the end of this routine
0
+    ; check if it is a character
0
+    (movl src dest-reg)
0
+    (op-and (imm chmask) dest-reg)
0
+    (cmp (imm chtag) dest-reg)
0
+    (je cont) ; yes it is
0
+    ; check if it is a basic type
0
+    (movl src dest-reg)
0
+    (op-and (imm basicmask) dest-reg)
0
+    (cmp (imm extendedtag) dest-reg) ; is it an extended type?
0
+    (jne cont)
0
+    (movl (deref (- extendedtag) src) dest-reg) ; get extended type tag
0
+    ; special case to handle strings' tag
0
+    (movl dest-reg tmp-reg) 
0
+    (op-and (imm fxmask) tmp-reg)
0
+    (cmp (imm strtag) tmp-reg)
0
+    (jne cont)
0
+    (movl (imm extendedtag) dest-reg) ; it's a string
0
+    (label cont)))
0
+
0
+(def emit-static-type-check-routine (name mask tag extended-p)
0
   (decl-globl (make-string "__check_" name))
0
   (emit-fun-header (make-string "__check_" name))
0
   (movl eax ebx)
0
-  (op-and (imm mask) ebx)
0
-  (cmp (imm tag) ebx)
0
+  (op-and (imm (if extended-p basicmask mask)) ebx)
0
+  (cmp (imm (if extended-p extendedtag tag)) ebx)
0
   (let err-label (unique-label)
0
     (jne err-label)
0
+    (if extended-p
0
+      (do
0
+        (movl (deref (- extendedtag) eax) ebx) ; get extended object tag
0
+        (if mask
0
+          (op-and (imm mask) ebx))
0
+        (cmp (imm tag) ebx)
0
+        (jne err-label)))
0
     (emit-fun-ret)
0
     (label err-label)
0
-    ; clear return address to avoid confusing __print_backtrace
0
-    (emit-save wordsize (imm 0))
0
-    (movl (imm 0) eax)
0
+    (subl (imm wordsize) esp) ; adjust esp to be consistent with labelcall
0
+    (emit-save wordsize (imm frame-sentinel))
0
+    (emit-save 0 (imm 0)) ; won't return, no need to have a valid ret. point
0
+    (if (and extended-p mask)
0
+      (movl (imm (+ extendedtag tag)) ecx)
0
+      (movl (imm tag) ecx))
0
+    (shll (imm fxshift) ecx) ; make the tag a fixnum
0
+    (emit-save (next-si 0) ecx) ; pass expected tag
0
+    (emit-get-tag eax ebx ecx)
0
+    (shll (imm fxshift) ebx)
0
+    (emit-save (next-si-n 0 2) ebx) ; pass tag found
0
+    (movl (imm 2) eax) ; number of args passed
0
     (jmp '__type_error)))
0
 
0
 (def emit-extended-type-check (si env tag . mask)
0
@@ -487,10 +526,10 @@
0
   (emit-type-check si env "vec"));vecmask vectag))
0
 
0
 (def emit-is-str (si env)
0
-  (emit-extended-type-check si env strtag fxmask))
0
+  (emit-type-check si env "str"));strtag fxmask))
0
 
0
 (def emit-is-float (si env)
0
-  (emit-extended-type-check si env floattag))
0
+  (emit-type-check si env "float"));floattag))
0
 
0
 (def emit-is-sym (si env)
0
   (emit-type-check si env "sym"));symbolmask symboltag))
0
@@ -498,6 +537,9 @@
0
 (def emit-is-closure (si env)
0
   (emit-type-check si env "closure"));closuremask closuretag))
0
 
0
+(def emit-is-continuation (si env)
0
+  (emit-type-check si env "continuation"))
0
+
0
 (def emit-exact-arg-count-check (si env n)
0
   (with (error-label (unique-label)
0
    cont-label (unique-label))
0
@@ -2110,23 +2152,15 @@
0
 (def emit-static-routines ()
0
   ; emit code for static routines
0
   ;(emit-thread-trampoline)
0
-  ; these routines expect return adress in ecx
0
-  (emit-static-type-check-routine "extended" basicmask extendedtag)
0
-  (emit-static-type-check-routine "fx" fxmask fxtag)
0
-  (emit-static-type-check-routine "ch" chmask chtag)
0
-  (emit-static-type-check-routine "cell" cellmask celltag)
0
-  (emit-static-type-check-routine "vec" vecmask vectag)
0
-  (emit-static-type-check-routine "sym" symbolmask symboltag)
0
-  (emit-static-type-check-routine "closure" closuremask closuretag)
0
-  ; function call (with exactly one arg) expects:
0
-  ; argument in eax
0
-  ; closure in ebx
0
-  ; stack index in edx
0
-  ; (emit-fun-header funcall-lbl)
0
-  
0
-  ; vec-ref
0
-  ; str-ref
0
-  nil)
0
+  (emit-static-type-check-routine "fx" fxmask fxtag nil)
0
+  (emit-static-type-check-routine "ch" chmask chtag nil)
0
+  (emit-static-type-check-routine "cell" cellmask celltag nil)
0
+  (emit-static-type-check-routine "vec" vecmask vectag nil)
0
+  (emit-static-type-check-routine "sym" symbolmask symboltag nil)
0
+  (emit-static-type-check-routine "closure" closuremask closuretag nil)
0
+  (emit-static-type-check-routine "str" fxmask strtag t)
0
+  (emit-static-type-check-routine "float" nil floattag t)
0
+  (emit-static-type-check-routine "continuation" nil continuation-tag t))
0
 
0
 (def emit-program ()
0
   ;(emit-static-routines)
0
@@ -2187,7 +2221,7 @@
0
 (install-primop '__restore-continuation
0
   (fn (si env cont-expr value)
0
     (emit-expr si env cont-expr)
0
-    (emit-extended-type-check si env continuation-tag)
0
+    (emit-is-continuation si env)
0
     (emit-save si eax)
0
     (emit-expr (next-si si) env value)
0
     (movl eax edi) ; save value to return from continuation

0
@@ -115,6 +115,8 @@
0
 
0
 (def acons (x) (consp x))
0
 
0
+(def car (x) (car x))
0
+
0
 (def not (x) (not x))
0
 
0
 (def symbolp (x) (symbolp x))

0
@@ -26,6 +26,7 @@
0
                    (read/tbl stream read-table))
0
       (err (str-append "Unknown char: " (char->str c))))))
0
 
0
+; handles ssyntax -- currently hardwired for f:g -> (compose f g)
0
 (def expand-ssyntax (str)
0
   (let aux nil
0
     (set aux (fn (pos)
0
@@ -54,7 +55,7 @@
0
       (feach (fn (c) (do (str-set str i c) (set i (+ i 1)))) l)
0
       (if (iso str "t") t 
0
           (iso str "nil") nil
0
-          (intern str)))))
0
+          (expand-ssyntax str)))))
0
 
0
 ; read-symbol must be the last, because it catches (almost) everything
0
 (set read-table 

0
@@ -13,7 +13,10 @@
0
   (def repl ()
0
     (ccc [set __error_continuation
0
              (fn (s)
0
-               (print (make-string "Error: " s))
0
+               (if (consp s)
0
+                 (print (make-string "Error: expected type " (car s) 
0
+                                     " but got type " (cdr s)))
0
+                 (print (make-string "Error: " s)))
0
                (__print_backtrace)
0
                (_ nil))])
0
     (write-string "arc> " out)

0
@@ -1,7 +1,41 @@
0
 ;  Copyright (c) 2008 Dissegna Stefano
0
 ;  Released under the terms of the GNU LGPL
0
 
0
-(labels ((__error 
0
+(labels ((__print_strings ; prints all strings passed to stderr
0
+           (code strings ()
0
+             (__if strings
0
+               (do
0
+                 (ffi-call "a_write" 2 (car strings) (str-len (car strings)))
0
+	         (labelcall __print_strings (cdr strings))))))
0
+
0
+         ; converts between type tags and type names
0
+         ; 0, 4 -> fixnum
0
+         ; 1 -> cons
0
+         ; 2 -> function
0
+         ; 3 -> symbol
0
+         ; 5 -> vector
0
+         ; 6 -> string
0
+         ; 15 -> character
0
+         ; 47 -> nil
0
+         ; 111 -> t
0
+         ; 175 -> continuation
0
+         ; 207 -> float
0
+         (__type_to_name 
0
+           (code (tag) ()
0
+             (__if (__if (is tag 0) t (is tag 4)) "fixnum"
0
+               (__if (is tag 1) "cons"
0
+                 (__if (is tag 2) "function"
0
+                   (__if (is tag 3) "symbol"
0
+                     (__if (is tag 5) "vector"
0
+                       (__if (is tag 6) "string"
0
+                         (__if (is tag 15) "char"
0
+                           (__if (is tag 47) "nil"
0
+                             (__if (is tag 111) "t"
0
+                               (__if (is tag 175) "continuation"
0
+                                 (__if (is tag 207) "float"
0
+                                   "unknown")))))))))))))
0
+
0
+         (__error 
0
      (code (msg) ()
0
              (__if __error_continuation
0
          (funcall __error_continuation msg)
0
@@ -10,10 +44,18 @@
0
            (__print_backtrace)
0
            (ffi-call "exit" 1)))))
0
 
0
-	 (__type_error 
0
-	   (code () ()
0
-	     (labelcall __error "Wrong type
0
-")))
0
+	 (__type_error
0
+	   (code (expected-tag got-tag) ()
0
+             (__let ((expected (labelcall __type_to_name expected-tag))
0
+                     (got (labelcall __type_to_name got-tag)))
0
+               (__if __error_continuation
0
+                 (funcall __error_continuation (cons expected got))
0
+	         (do
0
+                   (labelcall __print_strings "Wrong type: expected " 
0
+                                              expected ", got " got "
0
+")
0
+                   (__print_backtrace)
0
+                   (ffi-call "exit" 1))))))
0
    
0
    (__unbound_error
0
      (code (s) ()