ccall

README.md

@@ -49,16 +49,6 @@ Code emitted by the compiler depends upon the following libraries:
   macOS (with Homebrew) or `apt-get install libunistring-dev` on
   Ubuntu, or you can download and compile the source code.
 
-  If you are using Arch Linux, the `libunistring` package does not come with
-  the static library of `libunistring` (suffixed `.a`). You need to build it
-  from source by
-
-  ```console
-  $ curl -OL https://raw.githubusercontent.com/archlinux/svntogit-packages/packages/libunistring/trunk/PKGBUILD
-  $ echo "options=('staticlibs')" >> PKGBUILD
-  $ makepkg -si
-  ```
-
 ## Reference
 
-- [standard libraries](stdlibs.md)
+- [standard libraries](stdlibs.md)

villain/Makefile

@@ -1,12 +1,11 @@
 UNAME := $(shell uname)
 .PHONY: test std default
 
+libs='-lunistring'
 ifeq ($(UNAME), Darwin)
   format=macho64
-  libs='-lunistring'
 else
   format=elf64
-  libs='-l:libunistring.a'
 endif
 
 objs = \
@@ -17,7 +16,9 @@ objs = \
 	symbol.o \
 	str.o \
 	wrap.o \
-	utf8.o
+	utf8.o \
+	capi.o \
+	unistring.o
 
 default: runtime.o
 
@@ -27,6 +28,8 @@ char.o: villain.h utf8.h char.h
 io.o: runtime.h villain.h utf8.h
 symbol.o: str.h types.h villain.h
 str.o: types.h villain.h
+capi.o: runtime.h villain.h
+unistring.o: villain.h
 
 %.run:  %.o
 	@ racket -t formdps.rkt -m make $@

villain/capi.c

@@ -0,0 +1,21 @@
+/* capi.c: utility functions for C API */
+#include "villain.h"
+#include "runtime.h"
+
+void vl_check_type(vl_val x, vl_type type)
+{
+  if (vl_typeof(x) != type)
+    error_handler();
+}
+
+void vl_check_arity(uint64_t argc, uint64_t arity)
+{
+  if (argc != arity)
+    error_handler();
+}
+
+void vl_check_varity(uint64_t argc, uint64_t min, uint64_t max)
+{
+  if (argc < min || argc > max)
+    error_handler();
+}

villain/compile.rkt

@@ -158,26 +158,28 @@
 ;; Expr CEnv Boolean -> Asm
 (define (compile-e e c tail?)
   (match e
-    [(Int i)            (compile-value i)]
-    [(Bool b)           (compile-value b)]
-    [(Char c)           (compile-value c)]
-    [(Flonum f)         (compile-flonum f)]
-    [(Eof)              (compile-value eof)]
-    [(Empty)            (compile-value '())]
-    [(String s)         (compile-string s)]
-    [(Symbol s)         (compile-symbol s c)]
-    [(Vec ds)           (compile-vector ds c)]
-    [(Var x)            (compile-variable x c)]
-    [(App f es)         (compile-app f es c tail?)]
-    [(Apply f e)        (compile-apply f e c tail?)]
-    [(Prim0 p)          (compile-prim0 p c)]
-    [(Prim1 p e)        (compile-prim1 p e c)]
-    [(Prim2 p e1 e2)    (compile-prim2 p e1 e2 c)]
-    [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)]
-    [(If e1 e2 e3)      (compile-if e1 e2 e3 c tail?)]
-    [(Begin e1 e2)      (compile-begin e1 e2 c tail?)]
-    [(Let x e1 e2)      (compile-let x e1 e2 c tail?)]
-    [(Match e0 cs)      (compile-match e0 cs c tail?)]))
+    [(Int i)                    (compile-value i)]
+    [(Bool b)                   (compile-value b)]
+    [(Char c)                   (compile-value c)]
+    [(Flonum f)                 (compile-flonum f)]
+    [(Eof)                      (compile-value eof)]
+    [(Empty)                    (compile-value '())]
+    [(String s)                 (compile-string s)]
+    [(Symbol s)                 (compile-symbol s c)]
+    [(Vec ds)                   (compile-vector ds c)]
+    [(Var x)                    (compile-variable x c)]
+    [(App 'ccall
+          (cons (String f) es)) (compile-ccall (string->symbol f) es c)]
+    [(App f es)                 (compile-app f es c tail?)]
+    [(Apply f e)                (compile-apply f e c tail?)]
+    [(Prim0 p)                  (compile-prim0 p c)]
+    [(Prim1 p e)                (compile-prim1 p e c)]
+    [(Prim2 p e1 e2)            (compile-prim2 p e1 e2 c)]
+    [(Prim3 p e1 e2 e3)         (compile-prim3 p e1 e2 e3 c)]
+    [(If e1 e2 e3)              (compile-if e1 e2 e3 c tail?)]
+    [(Begin e1 e2)              (compile-begin e1 e2 c tail?)]
+    [(Let x e1 e2)              (compile-let x e1 e2 c tail?)]
+    [(Match e0 cs)              (compile-match e0 cs c tail?)]))
 
 (define (compile-e-tail e c)
   (compile-e e c #t))
@@ -385,29 +387,6 @@
                (Sal rax char-shift)
                (Xor rax type-char))]
          ['eof-object? (eq-imm val-eof)]
-         [(or 'char-whitespace? 'char-alphabetic?)
-          (let ((l (gensym)))
-            (seq (assert-char rax c)
-                 (pad-stack c)
-                 (Sar rax char-shift)
-                 (Mov rdi rax)
-                 (Call (char-op->uc p))
-                 (unpad-stack c)
-                 (Cmp rax 0)
-                 (Mov rax val-true)
-                 (Jne l)
-                 (Mov rax val-false)
-                 (Label l)))]
-         [(or 'char-upcase 'char-downcase 'char-titlecase)
-          (let ((l (gensym)))
-            (seq (assert-char rax c)
-                 (pad-stack c)
-                 (Sar rax char-shift)
-                 (Mov rdi rax)
-                 (Call (char-op->uc p))
-                 (unpad-stack c)
-                 (Sal rax char-shift)
-                 (Or rax type-char)))]
          ['write-byte
           (seq (assert-byte c)
                (pad-stack c)
@@ -1027,6 +1006,24 @@
              (Add rsp 16)
              (Jmp return))])]))
 
+;; Symbol [Listof Expr] CEnv -> Asm
+(define (compile-ccall f es c)
+  (let ([argc (length es)])
+    (seq (compile-es (reverse es) c) ; push args in reverse order
+         ;; +-------------+
+         ;; | c (argv[2]) |
+         ;; +-------------+         ^
+         ;; | b (argv[1]) |         | increasing addr
+         ;; +-------------+         |
+         ;; | a (argv[0]) |         |
+         ;; +-------------+ <- rsp
+         (Mov rdi argc)              ; argc
+         (Mov rsi rsp)               ; argv
+         (pad-stack-call c argc)
+         (Call f)
+         (unpad-stack-call c argc)
+         (Add rsp (* 8 argc)))))     ; pop args
+
 ;; CEnv -> Asm
 ;; Pad the stack to be aligned for a call with stack arguments
 (define (pad-stack-call c i)

villain/externs.rkt

@@ -1,5 +1,5 @@
 #lang racket
-(provide externs char-op->uc symbol->label)
+(provide externs symbol->label)
 (require "ast.rkt" "externs-stdlib.rkt" a86/ast)
 
 (define (externs p)
@@ -32,6 +32,9 @@
 
 (define (externs-e e)
   (match e
+    [(App 'ccall 
+          (cons (String f) es))
+     (list (Extern (string->symbol f)))]
     [(App f es)
      (append (externs-f f)
              (externs-es es))]
@@ -99,15 +102,6 @@
     #;['string->symbol 'str_to_symbol]  ;; always included now
     ['open-input-file 'open_input_file]
     ['close-input-port 'close_input_port]
-    [_ (char-op->uc o)]))
-
-(define (char-op->uc o)
-  (match o
-    ['char-alphabetic? 'uc_is_property_alphabetic]
-    ['char-whitespace? 'uc_is_property_white_space]
-    ['char-upcase 'uc_toupper]
-    ['char-downcase 'uc_tolower]
-    ['char-titlecase 'uc_totitle]
     [_ #f]))
 
 ;; Symbol -> Boolean

villain/lib/char.rkt

@@ -0,0 +1,21 @@
+#lang racket
+(provide char-alphabetic?
+         char-whitespace?
+         char-upcase
+         char-downcase
+         char-titlecase)
+
+(define (char-alphabetic? c)
+  (ccall "char_alphabetic" c))
+
+(define (char-whitespace? c)
+  (ccall "char_whitespace" c))
+
+(define (char-upcase c)
+  (ccall "char_upcase" c))
+
+(define (char-downcase c)
+  (ccall "char_downcase" c))
+
+(define (char-titlecase c)
+  (ccall "char_titlecase" c))

villain/parse.rkt

@@ -141,7 +141,6 @@
   '(add1 sub1 zero? char? write-byte write-char eof-object?
          integer->char char->integer box unbox empty? car cdr
          integer-length integer? 
-         char-alphabetic? char-whitespace? char-upcase char-downcase char-titlecase
          string-length string? integer?
          flonum?
          symbol->string string->symbol symbol?

villain/unistring.c

@@ -0,0 +1,64 @@
+/* unistring.c: wrapper for libunistring functions */
+#include <unictype.h>
+#include <unicase.h>
+#include "villain.h"
+
+vl_val char_alphabetic(uint64_t argc, vl_val *argv)
+{
+  vl_char c;
+
+  vl_check_arity(argc, 1);
+  vl_check_type(argv[0], VL_CHAR);
+
+  c = vl_unwrap_char(argv[0]);
+
+  return vl_wrap_bool(uc_is_property_alphabetic(c));
+}
+
+vl_val char_whitespace(uint64_t argc, vl_val *argv)
+{
+  vl_char c;
+
+  vl_check_arity(argc, 1);
+  vl_check_type(argv[0], VL_CHAR);
+
+  c = vl_unwrap_char(argv[0]);
+
+  return vl_wrap_bool(uc_is_property_white_space(c));
+}
+
+vl_val char_upcase(uint64_t argc, vl_val *argv)
+{
+  vl_char c;
+
+  vl_check_arity(argc, 1);
+  vl_check_type(argv[0], VL_CHAR);
+
+  c = vl_unwrap_char(argv[0]);
+
+  return vl_wrap_char(uc_toupper(c));
+}
+
+vl_val char_downcase(uint64_t argc, vl_val *argv)
+{
+  vl_char c;
+
+  vl_check_arity(argc, 1);
+  vl_check_type(argv[0], VL_CHAR);
+
+  c = vl_unwrap_char(argv[0]);
+
+  return vl_wrap_char(uc_tolower(c));
+}
+
+vl_val char_titlecase(uint64_t argc, vl_val *argv)
+{
+  vl_char c;
+
+  vl_check_arity(argc, 1);
+  vl_check_type(argv[0], VL_CHAR);
+
+  c = vl_unwrap_char(argv[0]);
+
+  return vl_wrap_char(uc_totitle(c));
+}

villain/villain.h

@@ -55,6 +55,16 @@ typedef struct vl_port {
 /* return the type of x */
 vl_type vl_typeof(vl_val x);
 
+/* check if type of x matches type.
+ * raise error on type mismatch. */
+void vl_check_type(vl_val x, vl_type type);
+/* check if argc matches arity
+ * raise error on arity mismatch. */
+void vl_check_arity(uint64_t argc, uint64_t arity);
+/* check if argc matches variable arity
+ * raise error on arity mismatch. */
+void vl_check_varity(uint64_t argc, uint64_t min, uint64_t max);
+
 /**
  * Wrap/unwrap villain values
  *