Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
LSH
lsh
Commits
dc535c06
Commit
dc535c06
authored
Dec 02, 1998
by
Niels Möller
Browse files
*** empty log message ***
Rev: src/make_class:1.2 Rev: src/reaper.c:1.3
parent
d438fcdc
Changes
2
Hide whitespace changes
Inline
Side-by-side
src/make_class
View file @
dc535c06
...
...
@@ -3,7 +3,8 @@
;; Reads a C source file on stdin. Comments of the form
;;
;; /* CLASS:
;; /*
;; 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))
(else
...
...
@@ -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
((pointer)
(c-declare base (list "(* (" name "))")))
((array)
(c-declare base (list "(" name ")[" (car args) "]")))
((function)
(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
"\n{\n"
" struct " (or super "lsh_object") " super;\n"
(map declare-var vars)
"};\n\n"))
(map (lambda (var)
(let ((type (var-type var)))
(list " " (c-declare (if (eq? 'method (var-category var))
(list 'pointer type)
type)
(var-name var)) ";\n")))
vars)
"};\n"))
(define (do-mark-function name vars)
(let ((objects (filter (lambda (x) (eq? 'object (var-category x)))
vars)))
(cond ((null? objects) #f)
(werror "do-mark-function\n")
(let ((objects (filter (lambda (x)
(eq? 'object (var-category x)))
vars))
(specials (filter (lambda (x)
(werror "x = ~S\n" x)
(and (eq? 'special (var-category x))
(var-marker x)))
vars)))
(werror "gazonk\n")
(cond ((and (null? objects) (null? specials)) #f)
(else
(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"
"{\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"
"}\n\n")))))
(list " " (var-marker var)
"(i->" (var-name var) ", mark);\n"))
specials)
"return "
(if (null? objects)
"0"
"(struct lsh_object *) (i->" (var-name (car vars)) ")")
";\n}\n\n")))))
(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))
((special)
(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)
(else
(list "st
ruct lsh_object *
do_"
(list "st
atic void
do_"
name "_free(struct lsh_object *o)\n"
"{\n"
" struct " name " *i = (struct " name " *) o;\n "
ops
"}\n\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")
"0")
", sizeof(struct " name "),\n "
(if mark-function (list "do_" name "_mark") "NULL") ",\n "
(if free-function (list "do_" name "_free") "NULL") ",\n"
"};\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)
"")
"};\n"
"#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
((class)
(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"))))
((meta)
(let ((name (get 'name attributes cadr))
(methods (get 'methods attributes cdr)))
(list "#ifndef CLASS_DEFINE\n"
"struct " name "_meta\n"
"{\n"
" struct lsh_class super;\n"
(map (lambda (m) (list " " m ";\n"))
methods)
"};\n"
"#endif /* !CLASS_DEFINE */\n\n")))
(else (list "#error Unknown expression type " type "\n")))))
(define main
...
...
src/reaper.c
View file @
dc535c06
...
...
@@ -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
);
}
else
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment