#! _SCSH_ \ -e main -s !# ;; Reads a C source file on stdin. Comments of the form ;; ;; /* ;; CLASS: ;; expression ;; */ ;; ;; are treated specially, and C code for the class is written to ;; stdout. Typically, the code is saved to a file and included by the ;; C source file in question. ;; FIXME: Perhaps the files should somehow be fed through the ;; preprocessor first? ;; FIXME: Turn this into a scheme48 module (define-syntax let-and (syntax-rules () ((let-and (expr) clause clauses ...) (and expr (let-and clause clauses ...))) ((let-and (name expr) clause clauses ...) (let ((name expr)) (and name (let-and clause clauses ...)))) ((let-and expr) expr))) (define (atom? o) (not (list? o))) (define (lambda? o) (and (pair? o) (eq? 'lambda (car o)))) (define (make-lambda formal body) `(lambda ,formal ,body)) (define lambda-formal cadr) (define lambda-body caddr) (define make-appliction list) (define application-op car) (define application-arg cadr) (define application-args cdr) (define (normalize-application op args) (if (null? args) op (normalize-application (make-appliction op (car args)) (cdr args)))) ;; Transform (a b c)-> ((a b) c) and ;; (lambda (a b) ...) -> (lambda a (lambda b ...) (define (make-preprocess specials) (define (preprocess expr) (if (atom? expr) expr (let ((op (car expr))) (cond ((and (atom? op) (assq op specials)) => (lambda (pair) ((cdr pair) (cdr expr) preprocess))) (else (normalize-application (preprocess op) (map preprocess (cdr expr)))))))) preprocess) (define preprocess-applications (make-preprocess '())) (define (do-lambda args preprocess) (let loop ((formals (reverse (car args))) (body (preprocess (cadr args)))) (if (null? formals) body (loop (cdr formals) (make-lambda (car formals) body))))) (define (do-let* args preprocess) (let loop ((definitions (reverse (car args))) (body (preprocess (cadr args)))) (if (null? definitions) body (loop (cdr definitions) (make-appliction (make-lambda (caar definitions) body) (preprocess (cadar definitions))))))) (define (do-let args preprocess) (let ((definitions (car args)) (body (cadr args))) (normalize-application (do-lambda (list (map car definitions) body) preprocess) (map cadr definitions)))) (define preprocess (make-preprocess `((lambda . ,do-lambda) (let . ,do-let) (let* . ,do-let*)))) (define (free-variable? v expr) (cond ((atom? expr) (eq? v expr)) ((lambda? expr) (and (not (eq? v (lambda-formal expr))) (free-variable? v (lambda-body expr)))) (else (or (free-variable? v (application-op expr)) (free-variable? v (application-arg expr)))))) (define (match pattern expr) (if (atom? pattern) (if (eq? '* pattern) (list expr) (and (eq? pattern expr) '())) (let-and ((pair? expr)) (op-matches (match (application-op pattern) (application-op expr))) (arg-matches (match (application-arg pattern) (application-arg expr))) (append op-matches arg-matches)))) (define (rule pattern f) (cons (preprocess-applications pattern) f)) (define (make-K e) (make-combine 'K e)) (define (make-S p q) (make-combine 'S p q)) ;; (define (make-B p) (make-combine 'B p)) ;; (define (make-C p q) (make-combine 'C p q)) ;; (define (make-S* p q) (make-combine 'S* p q)) ;; (define (make-B* p q) (make-combine 'B* p q)) ;; (define (make-C* p q) (make-combine 'C* p q)) ;; Some mor patterns that can ba useful for optimization. From "A ;; combinator-based compiler for a functional language" by Hudak & ;; Kranz. ;; S K => K I ;; S (K I) => I ;; S (K (K x)) => K (K x) ;; S (K x) I => x ;; S (K x) (K y) => K (x y) ;; S f g x = f x (g x) ;; K x y => x ;; I x => x ;; Y (K x) => x (define optimizations (list (rule '(S (K *) (K *)) (lambda (p q) (make-K (make-appliction p q)))) (rule '(S (K *) I) (lambda (p) p)) ;; (rule '(B K I) (lambda () 'K)) (rule '(S (K *) (B * *)) (lambda (p q r) (make-combine 'B* p q r))) (rule '(S (K *) *) (lambda (p q) (make-combine 'B p q))) (rule '(S (B * *) (K *)) (lambda (p q r) (make-combine 'C* p q r))) ;; (rule '(C (B * *) *) (lambda (p q r) (make-combine 'C* p q r))) (rule '(S * (K *)) (lambda (p q) (make-combine 'C p q))) (rule '(S (B * * ) r) (lambda (p q r) (make-combine 'S* p q r))))) (define (optimize expr) ;; (werror "optimize ~S\n" expr) (let loop ((rules optimizations)) ;; (if (not (null? rules)) (werror "trying pattern ~S\n" (caar rules)) ) (cond ((null? rules) expr) ((match (caar rules) expr) => (lambda (parts) (apply (cdar rules) parts))) (else (loop (cdr rules)))))) (define (optimize-application op args) (if (null? args) op (optimize-application (optimize (make-appliction op (car args))) (cdr args)))) (define (make-combine op . args) (optimize-application op args)) (define (translate-expression expr) (cond ((atom? expr) expr) ((lambda? expr) (translate-lambda (lambda-formal expr) (translate-expression (lambda-body expr)))) (else (make-appliction (translate-expression (application-op expr)) (translate-expression (application-arg expr)))))) (define (translate-lambda v expr) (cond ((atom? expr) (if (eq? v expr) 'I (make-K expr))) ((lambda? expr) (error "translate-lambda: Unexpected lambda" expr)) (else (make-S (translate-lambda v (application-op expr)) (translate-lambda v (application-arg expr)))))) (define (make-flat-application op arg) (if (atom? op) `(,op ,arg) `(,@op ,arg))) (define (flatten-application expr) (if (or (atom? expr) (lambda? expr)) expr (make-flat-application (flatten-application (application-op expr)) (flatten-application (application-arg expr))))) (define (translate expr) (flatten-application (translate-expression (preprocess expr)))) ;;; Test cases ;; (translate '(lambda (port connection) ;; (start-io (listen port connection) ;; (open-direct-tcpip connection)))) ;; ===> (C (B* S (B start-io) listen) open-direct-tcpip) ;; ;; (translate '(lambda (f) ((lambda (x) (f (lambda (z) ((x x) z)))) ;; (lambda (x) (f (lambda (z) ((x x) z)))) ))) ;; ===> (S (C B (S I I)) (C B (S I I))) ;; ;; (translate '(lambda (r) (lambda (x) (if (= x 0) 1 (* x (r (- x 1))))))) ;; ===> (B* (S (C* if (C = 0) 1)) (S *) (C B (C - 1))) (define (werror f . args) (display (apply format #f f args) 2)) (define (string-prefix? prefix s) (let ((l (string-length prefix))) (and (<= l (string-length s)) (string=? prefix (substring s 0 l))))) (define (read-expression p) (let ((line (read-line))) ; (werror "read line: '~s'\n" (if (eof-object? line) "" line)) (cond ((eof-object? line) line) ((p line) (read)) (else (read-expression p))))) (define (get key alist select) (cond ((assq key alist) => select) (else #f))) (define (append-deep o) ; (werror "append-deep: ~S\n" o) (cond ((string? o) o) ((symbol? o) (symbol->string o)) ((number? o) (number->string o)) (else (apply string-append (map append-deep o))))) (define (identity x) x) (define (filter p list) (cond ((null? list) list) ((p (car list)) (cons (car list) (filter p (cdr list)))) (else (filter p (cdr list))))) (define (implode list separator) (cond ((null? list) '()) ((null? (cdr list)) list) (else `(,(car list) ,separator ,@(implode (cdr list) separator))))) (define (atom? x) (or (symbol? x) (string? x))) ;; Variables are describes as lists (name . type) ;; Known types (and corresponding C declarations) are ;; ;; (string) struct ol_string *name ;; (object class) struct class *name ;; (bignum) mpz_t name ;; (simple c-type) c-type ;; (special c-type mark-fn free-fn) ;; (special-struct c-type mark-fn free-fn) ;; ;; (struct tag) ;; ;; (array type size) type name[size] ;; Variable size array (must be last) */ ;; (var-array type size-field) type name[1] ;; ;; (pointer type) type *name ;; (space type) Like pointer, but should be freed ;; ;; (function type . arg-types) type name(arg-types) ;; ;; NOTE: For function types, the arguments are represented simply as ;; strings or lists containing C declarations; they do not use the ;; type syntax. ;; ;; (method type args) ;; is transformed into (pointer (function type self-arg args)) before ;; processing, (define (type->category type) (if (atom? type) (type->category `(simple ,type)) (let ((tag (car type))) (case tag ((string object static-object simple special special-struct indirect-special space bignum struct) tag) ((array var-array pointer) (type->category (cadr type))) (else (error "make_class: type->category: Invalid type" type)))))) (define (type->declaration type expr) (if (atom? type) (type->declaration `(simple ,type) expr) (case (car type) ((string) (list "struct ol_string *" expr)) ((object) (list "struct " (cadr type) " *" expr)) ((static-object) (list "struct " (cadr type) " " expr)) ((struct) (list "struct " (cadr type) " " expr)) ((bignum) (list "mpz_t " expr)) ((simple special special-struct indirect-special) (list (cadr type) " " expr)) ((pointer space) (type->declaration (cadr type) (list "(*(" expr "))"))) ((array) (type->declaration (cadr type) (list "((" expr ")[" (caddr type) "])"))) ((var-array) (type->declaration (cadr type) (list "((" expr ")[1])"))) ((function) (type->declaration (cadr type) (list expr "(" (implode (cddr type) ", ") ")"))) (else (error "make_class: type->declaration: Invalid type" type))))) (define (type->mark type expr) (if (atom? type) (type->mark `(simple ,type) expr) (case (car type) ((string simple function space bignum) #f) ((object) (list "mark((struct ol_object *) " expr ");\n")) ((static-object) (list "mark((struct ol_object *) &" expr ");\n")) ((struct) (list (cadr type) "_mark(&" expr ", mark);\n")) ((pointer) (if (null? (cddr type)) (type->mark (cadr type) (list "*(" expr ")")) ;; The optional argument should be the name of ;; an instance variable holding the length of ;; the area pointed to (let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]")))) (and mark-k (list "{\n unsigned k;\n" " for (k=0; k" (caddr type) "; k++)\n" " " mark-k "}\n"))))) ((special) (let ((mark-fn (caddr type))) (and mark-fn (list mark-fn "(" expr ", mark);\n")))) ((indirect-special) (let ((mark-fn (caddr type))) (and mark-fn (list mark-fn "(&(" expr "), mark);\n")))) ((special-struct) (let ((mark-fn (caddr type))) (and mark-fn (list mark-fn "(&(" expr "), mark);\n")))) ;; FIXME: Doesn't handle nested arrays ((array) (let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]")))) (and mark-k (list "{\n unsigned k;\n" " for (k=0; k<" (caddr type) "; k++)\n" " " mark-k "}\n")))) ((var-array) (let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]")))) (and mark-k (list "{\n unsigned k;\n" " for (k=0; k" (caddr type) "; k++)\n" " " mark-k "}\n")))) (else (error "make_class: type->mark: Invalid type" type))))) (define (type->free type expr) (define (free/f f) (and f (list f "(" expr ");\n"))) (if (atom? type) (type->free `(simple ,type) expr) (case (car type) ((object simple function pointer) #f) ((static-object) (list "CLASS(" (cadr type) ").free_instance((struct ol_object *) &" expr ");\n")) ((struct) (list (cadr type) "_free(&" expr ");\n")) ((string) (free/f "ol_string_free")) ((bignum) (free/f "mpz_clear")) ((space) (free/f "ol_space_free")) ((special) (free/f (cadddr type))) ((special-struct) (let ((free-fn (cadddr type))) (and free-fn (list free-fn "(&(" expr "));\n")))) ((indirect-special) (let ((free-fn (cadddr type))) (and free-fn (list free-fn "(&(" expr "));\n")))) ((array) (let ((free-k (type->free (cadr type) (list "(" expr ")[k]")))) (and free-k (list "{\n unsigned k;\n" " for (k=0; k<" (caddr type) "; k++)\n" " " free-k "}\n")))) ((var-array) (let ((free-k (type->free (cadr type) (list "(" expr ")[k]")))) (and free-k (list "{\n unsigned k;\n" " for (k=0; k" (caddr type) "; k++)\n" " " free-k "}\n")))) (else (error "make_class: type->free: Invalid type" type))))) #! (define (type->init type expr) (if (atom? type) (type->init `(simple ,type) expr) (case (car type) ((object string space pointer) (list expr "= NULL;\n")) ((bignum) (list "mpz_init(" expr ");\n")) ((array) (let ((init-k (type->init (cadr type) (list "(" expr ")[k]")))) (and init-k (list "{\n unsigned k;\n" " for (k=0; k<" (caddr type) "; k++)\n" " " init-k "}\n")))) (else (error "make_class: type->init: Invalid type" type))))) !# (define var-name car) (define var-type cdr) (define (fix-method name var) (let ((type (var-type var)) (variable (var-name var))) (if (atom? type) var (case (car type) ((method) `(,variable pointer (function ,(cadr type) ("struct " ,name " *self") ,@(cddr type)))) ((indirect-method) `(,variable pointer (function ,(cadr type) ("struct " ,name " **self") ,@(cddr type)))) (else var))))) (define (do-instance-struct name super vars) ; (werror "do-instance-struct\n") (list "struct " name "\n{\n" " struct " (or super "ol_object") " super;\n" (map (lambda (var) (list " " (type->declaration (var-type var) (var-name var)) ";\n")) vars) "};\n")) (define (do-struct name super vars) ; (werror "do-struct\n") (list "struct " name "\n{\n" (map (lambda (var) (list " " (type->declaration (var-type var) (var-name var)) ";\n")) vars) "};\n")) (define (do-mark-function name vars) ; (werror "do-mark-function\n") (let ((markers (filter identity (map (lambda (var) (type->mark (var-type var) (list "i->" (var-name var)))) vars)))) ; (werror "gazonk\n") (and (not (null? markers)) (list "static void do_" name "_mark(struct ol_object *o, \n" "void (*mark)(struct ol_object *o))\n" "{\n" " struct " name " *i = (struct " name " *) o;\n" (map (lambda (x) (list " " x)) markers) "}\n\n")))) (define (do-free-function name vars) ; (werror "do-free-function\n") (let ((freers (filter identity (map (lambda (var) (type->free (var-type var) (list "i->" (var-name var)))) vars)))) ; (werror "gazonk\n") (and (not (null? freers)) (list "static void do_" name "_free(struct ol_object *o)\n" "{\n" " struct " name " *i = (struct " name " *) o;\n" (map (lambda (x) (list " " x)) freers) "}\n\n")))) (define (declare-struct-mark-function name) (list "void " name "_mark(struct " name " *i, \n" " void (*mark)(struct ol_object *o))")) (define (do-struct-mark-function name vars) ; (werror "do-struct-mark-function\n") (let ((markers (filter identity (map (lambda (var) (type->mark (var-type var) (list "i->" (var-name var)))) vars)))) ; (werror "gazonk\n") (list (declare-struct-mark-function name) "\n{\n" ; To avoid warnings for unused parameters " (void) mark; (void) i;\n" (map (lambda (x) (list " " x)) markers) "}\n\n"))) (define (declare-struct-free-function name) (list "void " name "_free(struct " name " *i)")) (define (do-struct-free-function name vars) ; (werror "do-struct-free-function\n") (let ((freers (filter identity (map (lambda (var) (type->free (var-type var) (list "i->" (var-name var)))) vars)))) ; (werror "gazonk\n") (list (declare-struct-free-function name) "\n{\n" ; To avoid warnings for unused parameters " (void) i;\n" (map (lambda (x) (list " " x)) freers) "}\n\n"))) (define (do-class name super mark-function free-function meta methods) (define initializer (list "{ STATIC_HEADER,\n " (if super ; FIXME: A cast (struct ol_class *) or something ; equivalent is needed if the super class is not a ; struct ol_class *. For now, fixed with macros ; expanding to the right component of extended class ; structures. (list "&" super "_class") "0") ", \"" name "\", sizeof(struct " name "),\n " (if mark-function (list "do_" name "_mark") "NULL") ",\n " (if free-function (list "do_" name "_free") "NULL") "\n" "}")) ; (werror "do-class\n") (if meta (list "struct " meta "_meta " name "_class_extended =\n" "{ " initializer (if methods (map (lambda (m) (list ",\n " m)) methods) "") "};\n" "#define " name "_class (" name "_class_extended.super)\n") (list "struct ol_class " name "_class =\n" initializer ";\n"))) (define (process-class attributes) (let ((name (get 'name attributes cadr)) (super (get 'super attributes cadr)) (raw-vars (get 'vars attributes cdr)) (meta (get 'meta attributes cadr)) (methods (get 'methods attributes cdr))) (werror "Processing class ~S\n" name) ; (werror "foo\n") (let ((vars (map (lambda (var) (fix-method name var)) raw-vars))) (let ((mark-function (do-mark-function name vars)) (free-function (do-free-function name vars))) ; (werror "baar\n") (list "#ifndef CLASS_DEFINE\n" (do-instance-struct name super vars) (if meta (list "extern struct " meta "_meta " name "_class_extended;\n") (list "extern struct ol_class " name "_class;\n")) "#endif /* !CLASS_DEFINE */\n\n" "#ifndef CLASS_DECLARE\n" (or mark-function "") (or free-function "") (do-class name super mark-function free-function meta methods) "#endif /* !CLASS_DECLARE */\n\n"))))) (define (process-meta attributes) (let ((name (get 'name attributes cadr)) (methods (get 'methods attributes cdr))) (werror "Processing meta ~S\n" name) (list "#ifndef CLASS_DEFINE\n" "struct " name "_meta\n" "{\n" " struct ol_class super;\n" (map (lambda (m) (list " " m ";\n")) methods) "};\n" "#endif /* !CLASS_DEFINE */\n\n"))) (define (process-struct attributes) (let ((name (get 'name attributes cadr)) (super (get 'super attributes cadr)) (raw-vars (get 'vars attributes cdr)) (meta (get 'meta attributes cadr)) (methods (get 'methods attributes cdr))) (werror "Processing struct ~S\n" name) ; (werror "foo\n") ;; FIXME: Is this really needed? (let ((vars (map (lambda (var) (fix-method name var)) raw-vars))) ; (werror "baar\n") (list "#ifndef CLASS_DEFINE\n" (do-struct name super vars) "extern " (declare-struct-mark-function name) ";\n" "extern " (declare-struct-free-function name) ";\n" "#endif /* !CLASS_DEFINE */\n\n" "#ifndef CLASS_DECLARE\n" (do-struct-mark-function name vars) (do-struct-free-function name vars) "#endif /* !CLASS_DECLARE */\n\n")))) ;;;; Expression compiler ;; Can't use load; it writes messages to stdout. ;;(load 'compiler) ;; Constants is an alist of (name value call_1 call_2 ... call_n) ;; where value is a C expression representing the value. call_i is ;; present, it is a function that can be called to apply the value to ;; i arguments directly. (define (make-output constants) ;; OP and ARGS are C expressons (define (apply-generic op args) ;; (werror "(apply-generic ~S)\n" (cons op args)) (if (null? args) op (apply-generic (list "A(" op ", " (car args) ")") (cdr args)))) ;; INFO is the (value [n]) associated with a constant, ;; and ARGS is a list of C expressions (define (apply-constant info args) ;; (werror "apply-constant : ~S\n" info) ;; (werror " args : ~S\n" args) (let ((calls (cdr info))) (if (null? calls) (apply-generic (car info) args) (let ((n (min (length calls) (length args)))) ;; (werror "n: ~S\n" n) (apply-generic (list (nth info n) "(" (implode (list-prefix args n) ", ") ")") (list-tail args n)))))) (define (lookup-global v) (cond ((assq v constants) => cdr) (else (error "make_class: undefined global" v)))) (define (output-expression expr) ;; (werror "output-expression ~S\n" expr) (if (atom? expr) (car (lookup-global expr)) (let ((op (application-op expr)) (args (map output-expression (application-args expr)))) (if (atom? op) (apply-constant (lookup-global op) args) (apply-generic op args))))) output-expression) (define (process-expr attributes) (define (declare-params params) (implode (map (lambda (var) (type->declaration (var-type var) (var-name var))) params) ", ")) (define (params->alist params) (map (lambda (var) (let ((name (var-name var))) (list name (list "((struct ol_object *) " name ")" )))) params)) ;; (werror "foo\n") (let ((name (get 'name attributes cadr)) (globals (or (get 'globals attributes cdr) '())) (params (get 'params attributes cdr)) (expr (get 'expr attributes cadr))) (werror "Processing expression ~S\n" name) (let ((translated (translate expr))) (werror "Compiled to ~S\n" translated) (list "static struct ol_object *\n" name "(" (if params (declare-params params) "void") ")\n{\n" (format #f " /* ~S */\n" translated) "#define A CLASS_APPLY\n" "#define I CLASS_VALUE_I\n" "#define K CLASS_VALUE_K\n" "#define K1 CLASS_APPLY_K_1\n" "#define S CLASS_VALUE_S\n" "#define S1 CLASS_APPLY_S_1\n" "#define S2 CLASS_APPLY_S_2\n" "#define B CLASS_VALUE_B\n" "#define B1 CLASS_APPLY_B_1\n" "#define B2 CLASS_APPLY_B_2\n" "#define C CLASS_VALUE_C\n" "#define C1 CLASS_APPLY_C_1\n" "#define C2 CLASS_APPLY_C_2\n" "#define Sp CLASS_VALUE_Sp\n" "#define Sp1 CLASS_APPLY_Sp_1\n" "#define Sp2 CLASS_APPLY_Sp_2\n" "#define Sp3 CLASS_APPLY_Sp_3\n" "#define Bp CLASS_VALUE_Bp\n" "#define Bp1 CLASS_APPLY_Bp_1\n" "#define Bp2 CLASS_APPLY_Bp_2\n" "#define Bp3 CLASS_APPLY_Bp_3\n" "#define Cp CLASS_VALUE_Cp\n" "#define Cp1 CLASS_APPLY_Cp_1\n" "#define Cp2 CLASS_APPLY_Cp_2\n" "#define Cp3 CLASS_APPLY_Cp_3\n" " return\n " ((make-output (append '( (I I) (K K K1) (S S S1 S2) (B B B1 B2) (C C C1 C2) (S* Sp Sp1 Sp2 Sp3) (B* Bp Bp1 Bp2 Bp3) (C* Cp Cp1 Cp2 Cp3)) globals (if params (params->alist params) '()))) translated) ";\n" "#undef A\n" "#undef I\n" "#undef K\n" "#undef K1\n" "#undef S\n" "#undef S1\n" "#undef S2\n" "#undef B\n" "#undef B1\n" "#undef B2\n" "#undef C\n" "#undef C1\n" "#undef C2\n" "#undef Sp\n" "#undef Sp1\n" "#undef Sp2\n" "#undef Sp3\n" "#undef Bp\n" "#undef Bp1\n" "#undef Bp2\n" "#undef Bp3\n" "#undef Cp\n" "#undef Cp1\n" "#undef Cp2\n" "#undef Cp3\n" "}\n")))) (define (process-input exp) (let ((type (car exp)) (body (cdr exp))) ;; (werror "process-class: type = ~S\n" type) (case type ((class) (process-class body)) ((meta) (process-meta body)) ((struct) (process-struct body)) ((expr) (process-expr body)) (else (list "#error Unknown expression type " type "\n"))))) (define main (let ((test (lambda (s) (string-prefix? "/* CLASS:" s)))) (lambda args (let ((exp (read-expression test))) (if (not (eof-object? exp)) (begin (display (append-deep (process-input exp))) (main)) 0))))) ; (main)