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

*** empty log message ***

Rev: src/make_class:1.2
Rev: src/reaper.c:1.3
parent d438fcdc
......@@ -3,7 +3,8 @@
;; Reads a C source file on stdin. Comments of the form
;; /* CLASS:
;; /*
;; expression
;; */
......@@ -11,6 +12,9 @@
;; 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?
(define (werror f . args)
(display (apply format #f f args) 2))
......@@ -21,7 +25,7 @@
(define (read-expression p)
(let ((line (read-line)))
(werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
; (werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
(cond ((eof-object? line) line)
((p line) (read))
(else (read-expression p)))))
......@@ -31,7 +35,7 @@
(else #f)))
(define (append-deep o)
(werror "append-deep: ~S\n" o)
; (werror "append-deep: ~S\n" o)
(cond ((string? o) o)
((symbol? o) (symbol->string o))
......@@ -47,41 +51,79 @@
;; Variables are describes as lists (category type name)
;; Known categories are object, simple, bignum, string, space, method
;; For function pointers (category simple or method), the type is the
;; return type, and the name includes the function pointer declaration
;; and prototype.
(define var-category car)
(define var-type cadr)
(define var-name caddr)
(define (declare-var var)
(list " " (var-type var) " " (var-name var) ";\n"))
(define var-extra cdddr)
(define (var-marker x) (car (var-extra x)))
(define (var-freer x) (cadr (var-extra x)))
(define (c-declare type name)
(if (pair? type)
(let ((modifier (car type))
(base (cadr type))
(args (cddr type)))
(case modifier
(c-declare base (list "(* (" name "))")))
(c-declare base (list "(" name ")[" (car args) "]")))
(c-declare base (list "(" name ")(" (car args) ")")))
(else (list "#error UNKNOWN MODIFIER " modifier))))
(list type " " name)))
;; FIXME: Method declarations could be made more friendly. For instance
;; (method int name ("struct foo *arg")) rather than
;; (method (function int "struct this_type *self struct foo *arg") name)
(define (do-struct name super vars)
(list "struct " name
" struct " (or super "lsh_object") " super;\n"
(map declare-var vars)
(map (lambda (var)
(let ((type (var-type var)))
(list " " (c-declare (if (eq? 'method (var-category var))
(list 'pointer type)
(var-name var)) ";\n")))
(define (do-mark-function name vars)
(let ((objects (filter (lambda (x) (eq? 'object (var-category x)))
(cond ((null? objects) #f)
(werror "do-mark-function\n")
(let ((objects (filter (lambda (x)
(eq? 'object (var-category x)))
(specials (filter (lambda (x)
(werror "x = ~S\n" x)
(and (eq? 'special (var-category x))
(var-marker x)))
(werror "gazonk\n")
(cond ((and (null? objects) (null? specials)) #f)
(list "struct lsh_object *do_"
(list "static struct lsh_object *do_"
name "_mark(struct lsh_object *o, \n"
"void (*mark)(struct lsh_object *o))\n"
" struct " name " *i = (struct " name " *) o;\n "
(if (null? objects)
(map (lambda (var)
(list " mark((struct lsh_object *) (i->"
(var-name var) "));\n"))
(cdr objects)))
(map (lambda (var)
(list " mark((struct lsh_object *) (i->"
(var-name var) "));\n"))
(cdr objects))
"return (struct lsh_object *) (i->" (var-name (car vars)) ");\n"
(list " " (var-marker var)
"(i->" (var-name var) ", mark);\n"))
"return "
(if (null? objects)
"(struct lsh_object *) (i->" (var-name (car vars)) ")")
(define (do-free-function name vars)
(define (free/f f var)
......@@ -93,47 +135,87 @@
((bignum) (free/f "mpz_clear" var))
((string) (free/f "lsh_string_free" var))
((space) (free/f "lsh_space_free" var))
(and (var-freer var)
(free/f (var-freer var) var)))
(else "#error make_class: Category " (var-category var) " unknown\n")))
(let ((ops (filter identity (map free-var vars))))
(cond ((null? ops) #f)
(list "struct lsh_object *do_"
(list "static void do_"
name "_free(struct lsh_object *o)\n"
" struct " name " *i = (struct " name " *) o;\n "
(define (do-class name super mark-function free-function methods)
(define (do-class name super mark-function free-function meta methods)
(define initializer
(list "{ STATIC_HEADER,\n "
(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.
(list "&" super "_class")
", 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")
(if methods
;; Would have to define a new struct
"#error make_class: methods not implemented"
(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)
"#define " name "_class (" name "_class_extended.super)\n")
(list "struct lsh_class " name "_class =\n"
initializer ";")))
initializer ";\n")))
(define (process-class exp)
(let ((name (get 'name exp cadr))
(super (get 'super exp cadr))
(vars (get 'vars exp cdr))
(methods (get 'methods exp cdr)))
(let ((mark-function (do-mark-function name vars))
(free-function (do-free-function name vars)))
(list (do-struct name super vars)
(or mark-function "")
(or free-function "")
(do-class name super mark-function free-function methods)))))
(let ((type (car exp))
(attributes (cdr exp)))
(werror "process-class: type = ~S\n" type)
(case type
(let ((name (get 'name attributes cadr))
(super (get 'super attributes cadr))
(vars (get 'vars attributes cdr))
(meta (get 'meta attributes cadr))
(methods (get 'methods attributes cdr)))
(werror "foo\n")
(let ((mark-function (do-mark-function name vars))
(free-function (do-free-function name vars)))
(werror "baar\n")
(list "#ifndef CLASS_DEFINE\n"
(do-struct name super vars)
(if meta
(list "extern struct " meta "_meta " name "_class_extended;\n")
(list "extern struct lsh_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"))))
(let ((name (get 'name attributes cadr))
(methods (get 'methods attributes cdr)))
(list "#ifndef CLASS_DEFINE\n"
"struct " name "_meta\n"
" struct lsh_class super;\n"
(map (lambda (m) (list " " m ";\n"))
"#endif /* !CLASS_DEFINE */\n\n")))
(else (list "#error Unknown expression type " type "\n")))))
(define main
......@@ -108,7 +108,7 @@ static void reap(struct reaper *r)
if (callback)
ALIST_SET(r->children, pid, 0);
ALIST_SET(r->children, pid, NULL);
EXIT_CALLBACK(callback, signaled, core, value);
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment