Skip to content

GitLab

Commit 862c1608 authored by Niels Möller's avatar Niels Möller
Browse files

Rewrote the functions for generating C code. 

Work in progress.

Rev: src/scm/gaba.scm:1.9
parent 8e54df3d
Hide whitespace changes
Inline Side-by-side
src/scm/gaba.scm
View file @ 862c1608
......@@ -65,6 +65,17 @@
(define (atom? o) (not (list? o)))
;; (define (atom? x) (or (symbol? x) (string? x)))
(define-syntax when
(syntax-rules ()
((when <cond> . <body>)
(if <cond> (begin . <body>)))))
(define-syntax unless
(syntax-rules ()
((unless <cond> . <body>)
(if (not <cond>) (begin . <body>)))))
;; Variables are describes as lists (name . type)
;; Known types (and corresponding C declarations) are
;;
......@@ -102,6 +113,132 @@
;; (const . type) Like type, but declared const.
;; Primarily used for const string.
;;; C code generation
;; A portion of C code is represented as a either
;;
;; an atom (string, symbol or number), or
;;
;; procedure taking a single INDENT argument, sending
;; output to current-output-stream, or
;;
;; a list, whose elements are displayed indented one more level.
;;
;; It would be cleaner to let indent be a dynamically bound variable.
(define (out level . args)
(for-each (lambda (o)
(cond ((procedure? o) (o level))
((list? o) (apply out (+ 1 level) o))
(else (display o))))
args))
; This isn't very optimal
(define (indent i)
(display "\n")
(let loop ((count 0))
(when (< count i)
(display " ")
(loop (+ 1 count)))))
#!
(define-syntax cdef
(syntax-rules () ((cdef <i> <spec>
<body>)
(define <spec>
(lambda <i> <body>)))))
!#
(define (c-append . args)
(lambda (i) (apply out i args)))
(define (c-var name) name)
(define (c-string name)
;; FIXME: Could do quoting better
(c-append "\"" name "\""))
(define (c-statement expr)
(c-append expr ";"))
(define (c-address expr)
(c-append "&(" expr ")"))
(define (c-nl o)
(c-append o indent))
(define (c-list separator list)
(if (null? list) '()
(cons (car list)
(map (lambda (o)
(c-append separator o))
(cdr list)))))
(define (c-list* separator . list) (c-list separator list))
(define (c-block statements)
(c-append "{" (map (lambda (s) (c-append indent s ";"))
statements)
indent "}"))
(define (c-block* . statements) (c-block statements))
(define (c-initializer expressions)
(c-append "{" (map (lambda (s) (c-append indent s ","))
expressions)
indent "}"))
(define (c-initializer* . expressions) (c-initializer expressions))
(define (c-prototype return name . args)
(c-append return indent name
"("
(if (null? args) "void" (c-list (c-nl ",") args))
")"))
(define (c-for var range body)
(c-append "for(" var "=0; "
var "<" range "; "
var "++)"
indent (list body)))
(define (c-call f . args)
(c-append f "(" (c-list (c-append "," indent) args) ")"))
(define (c-declare var)
(define (c-decl-1 type expr)
(case (car type)
((simple special indirect-special)
(c-append (cadr type) " " expr))
((string)
(c-append "struct lsh_string *" expr))
((object)
(c-append "struct " (cadr type) " *" expr))
((struct)
(c-append "struct " (cadr type) " " expr))
((bignum)
(c-append "mpz_t " expr))
((pointer space)
(c-decl-1 (cadr type)
(c-append "(*(" expr "))")))
((array)
(c-decl-1 (cadr type)
(c-append "((" expr ")[" (caddr type) "])")))
((var-array)
(c-decl-1 (cadr type)
(c-append "((" expr ")[1])")))
((function)
(c-decl-1 (cadr type)
(c-append expr "(" (c-list "," (cddr type)) ")")))
((const)
(c-append "const" (c-decl-1 (cdr type) expr)))
(else (error "c-decl: Invalid type " type))))
(c-decl-1 (var-type var) (var-name var)))
(define (c-struct name vars)
(c-append "struct " name indent
(c-block (map c-declare vars))
";" indent))
(define (type->category type)
(if (atom? type)
(type->category `(simple ,type))
......@@ -114,6 +251,7 @@
(else (error "make_class: type->category: Invalid type" type))))))
(define (type->declaration type expr)
(if (atom? type)
(type->declaration `(simple ,type) expr)
......@@ -267,6 +405,176 @@
,@(cddr type))))
(else var)))))
; New version
(define (make-instance-struct name super vars)
(c-struct name (cons `(super struct ,(or super "lsh_object"))
vars)))
; For counter variables
(define make-var
(let ((*count* 0))
(lambda ()
(set! *count* (+ 1 *count*))
(c-append "k" *count*))))
; Invokes f on type and expression for each variable.
(define (map-variables f vars pointer)
(filter identity (map (lambda (var)
(f (var-type var)
(c-append pointer "->" (var-name var))))
vars)))
(define (make-marker type expr)
(case (car type)
((string simple function bignum) #f)
((object) (c-call "mark" (c-append "(struct lsh_object *) " expr)))
((struct) (c-call (c-append (cadr type) "_mark")
(c-address expr)
"mark"))
((pointer space)
(if (null? (cddr type))
(make-marker (cadr type)
(c-append "*(" expr ")"))
;; The optional argument should be the name of
;; an instance variable holding the length of
;; the area pointed to.
(let* ((counter (make-var))
(mark-k (make-marker (cadr type)
(c-append "(" expr ")[" counter "]"))))
(and mark-k
(c-block* (c-declare `( ,counter simple unsigned))
(c-for counter (c-append "i->" (caddr type))
mark-k))))))
((special)
(let ((mark-fn (caddr type)))
(and mark-fn (c-call mark-fn expr "mark"))))
((indirect-special)
(let ((mark-fn (caddr type)))
(and mark-fn (c-call mark-fn
(c-address expr)
"mark"))))
((array)
(let* ((counter (make-var))
(mark-k (make-marker (cadr type)
(c-append "(" expr ")[" counter "]"))))
(and mark-k
(c-block* (c-declare `( ,counter simple unsigned))
(c-for counter (caddr type)
mark-k)))))
((var-array)
(let* ((counter (make-var))
(mark-k (make-marker (cadr type)
(c-append "(" expr ")[" counter "]"))))
(and mark-k
(c-block* (c-declare `( ,counter simple unsigned))
(c-for counter (c-append "i->" (caddr type))
mark-k)))))
((const) (make-marker (cdr type) expr))
(else (error "make-marker: Invalid type " type))))
(define (make-mark-function name vars)
(let ((markers (map-variables make-marker vars "i")))
(and (not (null? markers))
(c-append (c-prototype "static void" (c-append "do_" name "_mark")
"struct lsh_object *o"
"void (*mark)(struct lsh_object *o)")
indent
(c-block (cons (c-append "struct " name
" *i = (struct " name " *) o;")
markers))
indent))))
(define (make-freer type expr)
(case (car type)
((object simple function pointer) #f)
((struct) (c-call (c-append (cadr type) "_free") (c-address expr)))
((string) (c-call "lsh_string_free" expr))
((bignum) (c-call "mpz_clear" expr))
((space) (c-call "lsh_space_free" expr))
((special) (c-call (cadddr type) expr))
((indirect-special)
(let ((free (cadddr type)))
(and free (c-call free (c-address expr)))))
((array)
(let* ((counter (make-var))
(free-k (make-freer (cadr type)
(c-append "(" expr ")[" counter "]"))))
(and free-k
(c-block* (c-declare `( ,counter simple unsigned))
(c-for counter (caddr type)
free-k)))))
((var-array)
(let* ((counter (make-var))
(free-k (make-freer (cadr type)
(c-append "(" expr ")[" counter "]"))))
(and free-k
(c-block* (c-declare `( ,counter simple unsigned))
(c-for counter (c-append "i->" (caddr type))
free-k)))))
((const) (make-freer (cdr type) expr))
(else (error "make-freer: Invalid type " type))))
(define (make-free-function name vars)
(let ((freers (map-variables make-freer vars "i")))
(and (not (null? freers))
(c-append (c-prototype "static void" (c-append "do_" name "_free")
"struct lsh_object *o)")
(c-block (cons (c-append "struct " name
" *i = (struct " name " *) o;")
freers))
indent))))
(define (struct-mark-prototype name)
(c-append "void " name "_mark(struct " name " *i,\n"
" void (*mark)(struct lsh_object *o))"))
(define (struct-mark-function name vars)
(c-append (struct-mark-prototype name) indent
(c-block
;; To avoid warnings for unused parameters
(cons "(void) mark; (void) i;"
(map-variables make-marker vars "i")))))
(define (struct-free-prototype name)
(c-append "void " name "_free(struct " name " *i)"))
(define (struct-free-function name vars)
(c-append (struct-mark-prototype name) indent
(c-block
;; To avoid warnings for unused parameters
(cons "(void) mark; (void) i;"
(map-variables make-freer vars "i")))))
(define (make-class name super mark free meta methods)
(let ((initializer
(c-initializer*
"STATIC_HEADER"
(if super
;; FIXME: A cast (struct lsh_class *) or something
;; equivalent is needed if the super class is not a
;; struct lsh_class *. For now, fixed with macros
;; expanding to the right component of extended class
;; structures.
(c-address (c-append super "_class"))
"NULL")
(c-string name)
(c-call "sizeof" (c-append "struct " name))
(if mark (c-append "do_" name "_mark") "NULL")
(if free (c-append "do_" name "_free") "NULL"))))
(if meta
(c-append "struct " meta "_meta "name "_class_extended ="
indent
(c-initializer (cons initializer (or methods '())))
";" indent)
(c-append "struct lsh_class " name "_class ="
indent initializer ";" indent))))
(define (make-meta name methods)
(c-append "struct " name "_meta" indent
(c-block methods) ";" indent))
(define (do-instance-struct name super vars)
; (werror "do-instance-struct\n")
(list "struct " name
......@@ -392,10 +700,39 @@
(list "struct lsh_class " name "_class =\n"
initializer ";\n")))
(define (preprocess name vars)
(define (preprocess-type type)
(if (atom? type)
`(simple ,type)
(case (car type)
;; Primitive types
((string object bignum simple special indirect-special struct)
type)
;; Second element is a type
((array var-array pointer space function)
`( ,(car type) ,(preprocess-type (cadr type)) ,@(cddr type)))
;; Tail is a type
((const)
(cons 'const (preprocess-type (cdr type))))
;; Shorthands
((method)
`(pointer (function ,(preprocess-type (cadr type))
("struct " ,name " *self")
,@(cddr type)))))
((indirect-method)
`(pointer (function ,(preprocess-type (cadr type))
("struct " ,name " **self")
,@(cddr type))))
(else (error "preprocess-type: Invalid type " type))))
(map (lambda (var)
(cons (var-name var) (preprocess-type (var-type var))))
vars))
(define (class-annotate name super meta)
(list "/*\nCLASS:" name ":" (or super "")
(if meta (list ":" meta "_meta") "") "\n*/\n"))
(c-append "/*\nCLASS:" name ":" (or super "")
(if meta (list ":" meta "_meta") "") "\n*/\n"))
(define (process-class attributes)
(let ((name (get 'name attributes cadr))
(super (get 'super attributes cadr))
......@@ -404,40 +741,35 @@
(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)))
(let ((vars (preprocess name raw-vars)))
(let ((mark-function (make-mark-function name vars))
(free-function (make-free-function name vars)))
; (werror "baar\n")
(list (class-annotate name super meta)
"#ifndef GABA_DEFINE\n"
(do-instance-struct name super vars)
(if meta
(list "extern struct " meta "_meta "
name "_class_extended;\n"
"#define " name "_class (" name "_class_extended.super)\n")
(list "extern struct lsh_class " name "_class;\n"))
"#endif /* !GABA_DEFINE */\n\n"
"#ifndef GABA_DECLARE\n"
(or mark-function "")
(or free-function "")
(do-class name super mark-function free-function
meta methods)
"#endif /* !GABA_DECLARE */\n\n")))))
(c-append (class-annotate name super meta)
"#ifndef GABA_DEFINE\n"
(make-instance-struct name super vars)
(if meta
(c-append "extern struct " meta "_meta "
name "_class_extended;\n"
"#define " name "_class (" name
"_class_extended.super)\n")
(c-append "extern struct lsh_class " name "_class;\n"))
"#endif /* !GABA_DEFINE */\n\n"
"#ifndef GABA_DECLARE\n"
(or mark-function "")
(or free-function "")
(make-class name super mark-function free-function
meta methods)
"#endif /* !GABA_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 GABA_DEFINE\n"
"struct " name "_meta\n"
"{\n"
" struct lsh_class super;\n"
(map (lambda (m) (list " " m ";\n"))
methods)
"};\n"
"#endif /* !GABA_DEFINE */\n\n")))
(c-append "#ifndef GABA_DEFINE\n"
(make-meta name methods)"struct " name "_meta\n"
"#endif /* !GABA_DEFINE */"
indent)))
(define (process-struct attributes)
(let ((name (get 'name attributes cadr))
......@@ -449,18 +781,17 @@
(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)))
(let ((vars (preprocess name raw-vars)))
; (werror "baar\n")
(list "#ifndef GABA_DEFINE\n"
(do-struct name super vars)
"extern " (declare-struct-mark-function name) ";\n"
"extern " (declare-struct-free-function name) ";\n"
"#endif /* !GABA_DEFINE */\n\n"
"#ifndef GABA_DECLARE\n"
(do-struct-mark-function name vars)
(do-struct-free-function name vars)
"#endif /* !GABA_DECLARE */\n\n"))))
(c-append "#ifndef GABA_DEFINE\n"
(c-struct name vars)
"extern " (struct-mark-prototype name) ";\n"
"extern " (struct-free-prototype name) ";\n"
"#endif /* !GABA_DEFINE */\n\n"
"#ifndef GABA_DECLARE\n"
(struct-mark-function name vars)
(struct-free-function name vars)
"#endif /* !GABA_DECLARE */\n\n"))))
;;;; Expression compiler
......@@ -530,77 +861,77 @@
(werror "Compiled to ~S\n" translated)
;; (werror "Globals: ~S\n" globals)
;; (werror "Params: ~S\n" params)
(list "static struct lsh_object *\n" name "("
(if params (declare-params params) "void")
")\n{\n"
(format #f " /* ~S */\n" translated)
"#define A GABA_APPLY\n"
"#define I GABA_VALUE_I\n"
"#define K GABA_VALUE_K\n"
"#define K1 GABA_APPLY_K_1\n"
"#define S GABA_VALUE_S\n"
"#define S1 GABA_APPLY_S_1\n"
"#define S2 GABA_APPLY_S_2\n"
"#define B GABA_VALUE_B\n"
"#define B1 GABA_APPLY_B_1\n"
"#define B2 GABA_APPLY_B_2\n"
"#define C GABA_VALUE_C\n"
"#define C1 GABA_APPLY_C_1\n"
"#define C2 GABA_APPLY_C_2\n"
"#define Sp GABA_VALUE_Sp\n"
"#define Sp1 GABA_APPLY_Sp_1\n"
"#define Sp2 GABA_APPLY_Sp_2\n"
"#define Sp3 GABA_APPLY_Sp_3\n"
"#define Bp GABA_VALUE_Bp\n"
"#define Bp1 GABA_APPLY_Bp_1\n"
"#define Bp2 GABA_APPLY_Bp_2\n"
"#define Bp3 GABA_APPLY_Bp_3\n"
"#define Cp GABA_VALUE_Cp\n"
"#define Cp1 GABA_APPLY_Cp_1\n"
"#define Cp2 GABA_APPLY_Cp_2\n"
"#define Cp3 GABA_APPLY_Cp_3\n"
;; " trace(\"Entering " name "\\n\");\n"
" return MAKE_TRACE(\"" name "\", \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 );\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"))))
(c-append (c-prototype "static struct lsh_object *" name
(if params (declare-params params) "void"))
indent "{\n"
(format #f " /* ~S */\n" translated)
"#define A GABA_APPLY\n"
"#define I GABA_VALUE_I\n"
"#define K GABA_VALUE_K\n"
"#define K1 GABA_APPLY_K_1\n"
"#define S GABA_VALUE_S\n"
"#define S1 GABA_APPLY_S_1\n"
"#define S2 GABA_APPLY_S_2\n"
"#define B GABA_VALUE_B\n"
"#define B1 GABA_APPLY_B_1\n"
"#define B2 GABA_APPLY_B_2\n"
"#define C GABA_VALUE_C\n"
"#define C1 GABA_APPLY_C_1\n"
"#define C2 GABA_APPLY_C_2\n"
"#define Sp GABA_VALUE_Sp\n"
"#define Sp1 GABA_APPLY_Sp_1\n"
"#define Sp2 GABA_APPLY_Sp_2\n"
"#define Sp3 GABA_APPLY_Sp_3\n"
"#define Bp GABA_VALUE_Bp\n"
"#define Bp1 GABA_APPLY_Bp_1\n"
"#define Bp2 GABA_APPLY_Bp_2\n"
"#define Bp3 GABA_APPLY_Bp_3\n"
"#define Cp GABA_VALUE_Cp\n"
"#define Cp1 GABA_APPLY_Cp_1\n"
"#define Cp2 GABA_APPLY_Cp_2\n"
"#define Cp3 GABA_APPLY_Cp_3\n"
;; " trace(\"Entering " name "\\n\");\n"
" return MAKE_TRACE(\"" name "\", \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 );\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))
......@@ -619,7 +950,7 @@
(let ((exp (read-expression test)))
(if (not (eof-object? exp))