(define (include-cdecls library)
;; Toplevel entry point for the generator.
- ;; Returns a new C-INCLUDES structure.
+ ;; Returns a new c-includes structure.
(let ((includes (make-c-includes library))
(cwd (if (param:loading?)
(directory-pathname (current-load-pathname))
(define current-filename)
(define (include-cdecl-file filename cwd twd includes)
- ;; Adds the C declarations in FILENAME to INCLUDES. Interprets
- ;; FILENAME relative to CWD (current working directory).
- ;; Abbreviates namestrings under TWD (topmost working, build directory).
+ ;; Adds the C declarations in filename to includes. Interprets
+ ;; filename relative to cwd (current working directory).
+ ;; Abbreviates namestrings under twd (topmost working, build directory).
(let* ((pathname (->simple-pathname
(merge-pathnames (pathname-default-type filename "cdecl")
(else (loop again (fix:1+ count)))))))
(define (include-cdecl form cwd twd includes)
- ;; Add a top-level C declaration to INCLUDES. If it is an
- ;; include, interprete the included filenames relative to CWD
+ ;; Add a top-level C declaration to includes. If it is an
+ ;; include, interprete the included filenames relative to cwd
;; (current working directory).
(if (not (and (pair? form) (symbol? (car form)) (pair? (cdr form))))
(cerror form "malformed top level C declaration"))
unspecific)
(define (include-typedef form name rest includes)
- ;; Add a top-level (typedef NAME . REST) C declaration to INCLUDES.
+ ;; Add a top-level (typedef name . rest) C declaration to includes.
(if (not (and (symbol? name)
(pair? rest) (null? (cdr rest))))
(cerror form "malformed typedef declaration"))
unspecific)))
(define (include-struct form name members includes)
- ;; Add a top-level (struct NAME . MEMBERS) C declaration to INCLUDES.
+ ;; Add a top-level (struct name . members) C declaration to includes.
(if (not (and (symbol? name) (pair? members) (list? members)))
(cerror form "malformed named struct declaration"))
(let* ((structs (c-includes/structs includes))
(entry (assq name structs)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'STRUCT
+ (let* ((anon (cons 'struct
(map (lambda (member)
(valid-struct-member member includes))
members)))
unspecific)))
(define (valid-struct-member form includes)
- ;; Returns (NAME . CTYPE) given a MEMBER C declaration.
- ;; Adds any internal named struct/union/enum types to INCLUDES.
+ ;; Returns (name . ctype) given a member C declaration.
+ ;; Adds any internal named struct/union/enum types to includes.
(if (not (and (pair? form) (symbol? (car form))
(pair? (cdr form)) (null? (cddr form))))
(cerror form "malformed struct member"))
(cons name ctype)))
(define (include-union form name members includes)
- ;; Add a top-level (union NAME . MEMBERS) C declaration to INCLUDES.
+ ;; Add a top-level (union name . members) C declaration to includes.
(if (not (and (symbol? name) (pair? members) (list? members)))
(cerror form "malformed named union declaration"))
(let* ((unions (c-includes/unions includes))
(entry (assq name unions)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'UNION
+ (let* ((anon (cons 'union
(map (lambda (member)
(valid-union-member member includes))
members)))
unspecific)))
(define (valid-union-member form includes)
- ;; Returns (NAME . CTYPE) given a MEMBER C declaration.
- ;; Adds any internal named struct/union/enum types to INCLUDES.
+ ;; Returns (name . ctype) given a member C declaration.
+ ;; Adds any internal named struct/union/enum types to includes.
(if (not (and (pair? form) (symbol? (car form))
(pair? (cdr form)) (null? (cddr form))))
(cerror form "malformed union member"))
(cons name ctype)))
(define (include-enum form name constants includes)
- ;; Add a top-level (enum NAME . CONSTANTS) C declaration to INCLUDES.
- ;; Also accepts an unnamed (enum . CONSTANTS) C declaration.
+ ;; Add a top-level (enum name . constants) C declaration to includes.
+ ;; Also accepts an unnamed (enum . constants) C declaration.
(if (not (list? constants))
(cerror form "malformed named enum declaration"))
(if (symbol? name)
(let* ((enums (c-includes/enums includes))
(entry (assq name enums)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'ENUM
+ (let* ((anon (cons 'enum
(valid-enum-constants constants includes)))
(info (cons anon current-filename)))
(set-c-includes/enums!
(valid-enum-constants (cdr form) includes)))
(define (valid-enum-constants forms includes)
- ;; Returns a list of (NAME) pairs for each enum constant declaration
- ;; in FORMS. Also adds enum constants to INCLUDES.
+ ;; Returns a list of (name) pairs for each enum constant declaration
+ ;; in forms. Also adds enum constants to includes.
(let loop ((forms forms))
(if (null? forms) '()
(let ((name (valid-enum-constant (car forms) includes)))
(cons name (loop (cdr forms)))))))
(define (valid-enum-constant form includes)
- ;; Returns (NAME), the name of the validated enum constant declared
- ;; by FORM. Immediately adds the constant to the list in INCLUDES,
+ ;; Returns (name), the name of the validated enum constant declared
+ ;; by form. Immediately adds the constant to the list in includes,
;; checking that it is not already there.
(if (not (and (pair? form) (symbol? (car form))
;; 1 or 2 args
(define (include-function form rettype rest includes)
;; Callouts/backs have much in common here, thus this shared
- ;; procedure, which uses the keyword still at the head of FORM to
- ;; munge the correct alist in INCLUDES.
+ ;; procedure, which uses the keyword still at the head of form to
+ ;; munge the correct alist in includes.
(if (not (and (pair? rest) (symbol? (car rest))
(list? (cdr rest))))
(cerror form "malformed " (symbol->string (car form)) " declaration"))
(let* ((name (car rest))
(params (cdr rest))
- (others (if (eq? 'EXTERN (car form))
+ (others (if (eq? 'extern (car form))
(c-includes/callouts includes)
(c-includes/callbacks includes)))
(entry (assq name others)))
(valid-ctype rettype includes)
(valid-params params includes)
current-filename))))
- (if (eq? 'EXTERN (car form))
+ (if (eq? 'extern (car form))
(set-c-includes/callouts! includes (cons new others))
(set-c-includes/callbacks! includes (cons new others)))
unspecific)))
(define (valid-params forms includes)
- ;; Returns a list -- (NAME CTYPE) for each parameter declaration
- ;; form in FORMS.
+ ;; Returns a list -- (name ctype) for each parameter declaration
+ ;; form in forms.
(if (null? forms) '()
(cons (valid-param (car forms) includes)
(valid-params (cdr forms) includes))))
(define (valid-param form includes)
- ;; Returns (NAME CTYPE) after validating FORM.
+ ;; Returns (name ctype) after validating form.
(if (not (and (pair? form) (symbol? (car form))
(pair? (cdr form))
(null? (cddr form))))
char-set:alphanumeric)))
(define (valid-ctype form includes)
- ;; Returns a valid ctype expression, a copy of FORM. Modifies
- ;; INCLUDES with any internal struct/union/enum declarations.
+ ;; Returns a valid ctype expression, a copy of form. Modifies
+ ;; includes with any internal struct/union/enum declarations.
(cond ((symbol? form) form)
((ctype/pointer? form) form)
((ctype/const? form)
- (list 'CONST (valid-ctype (cadr form) includes)))
+ (list 'const (valid-ctype (cadr form) includes)))
((ctype/struct-name? form) form)
((ctype/struct-anon? form)
- (cons 'STRUCT (map (lambda (member)
+ (cons 'struct (map (lambda (member)
(valid-struct-member member includes))
(cdr form))))
((ctype/struct-named? form)
(include-struct form (cadr form) (cddr form) includes)
- (list 'STRUCT (cadr form)))
+ (list 'struct (cadr form)))
((ctype/union-name? form) form)
((ctype/union-anon? form)
- (cons 'UNION (map (lambda (member)
+ (cons 'union (map (lambda (member)
(valid-union-member member includes))
(cdr form))))
((ctype/union-named? form)
(include-union form (cadr form) (cddr form))
- (list 'UNION (cadr form)))
+ (list 'union (cadr form)))
((ctype/enum-name? form) form)
((ctype/enum-anon? form)
- (cons 'ENUM (valid-enum-constants (cdr form) includes)))
+ (cons 'enum (valid-enum-constants (cdr form) includes)))
((ctype/enum-named? form)
(include-enum form (cadr form) (cddr form) includes)
- (list 'ENUM (cadr form)))
+ (list 'enum (cadr form)))
((ctype/array? form)
- (list 'ARRAY
+ (list 'array
(valid-ctype (ctype-array/element-type form) includes)
(ctype-array/size form)))
(make-condition-type
'ffi-cdecl-error
condition-type:error
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
(lambda (condition port)
(write-string "Error: " port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string ":" port)
- (write-string (access-condition condition 'FILENAME) port)
+ (write-string (access-condition condition 'filename) port)
(write-string ": " port)
- (write (access-condition condition 'FORM) port))))
+ (write (access-condition condition 'form) port))))
(define cerror
(let ((signaller (condition-signaller condition-type:cerror
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
standard-error-handler)))
(named-lambda (cerror form message . args)
(signaller form current-filename
(make-condition-type
'ffi-cdecl-warning
condition-type:warning
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
(lambda (condition port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string ":" port)
- (write-string (access-condition condition 'FILENAME) port)
+ (write-string (access-condition condition 'filename) port)
(write-string ": " port)
- (write (access-condition condition 'FORM) port))))
+ (write (access-condition condition 'form) port))))
(define cwarn
(let ((signaller (condition-signaller condition-type:cwarn
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
standard-warning-handler)))
(named-lambda (cwarn form message . args)
- (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
+ (with-simple-restart 'muffle-warning "Ignore warning."
(lambda ()
(signaller form current-filename
(apply string-append
;;; C Types
(define (ctype/basic? ctype)
- ;; Returns #t iff CTYPE is a basic C type, e.g. char, int or double.
+ ;; Returns #t iff ctype is a basic C type, e.g. char, int or double.
(and (symbol? ctype)
(not (eq? ctype '*))
(assq ctype peek-poke-primitives)))
(define (ctype/pointer? ctype)
- ;; Returns #t iff CTYPE is a pointer type, e.g. (* GtkWidget).
+ ;; Returns #t iff ctype is a pointer type, e.g. (* |GtkWidget|).
(or (eq? ctype '*)
(and (pair? ctype) (eq? '* (car ctype))
(pair? (cdr ctype)) (null? (cddr ctype)))))
(define ctype-pointer/target-type cadr)
(define (ctype/void? ctype)
- (eq? ctype 'VOID))
+ (eq? ctype 'void))
(define (ctype/const? ctype)
- (and (pair? ctype) (eq? 'CONST (car ctype))
+ (and (pair? ctype) (eq? 'const (car ctype))
(pair? (cdr ctype)) (null? (cddr ctype))))
(define ctype-const/qualified-type cadr)
(define (ctype/struct-name? ctype)
- ;; Returns #t iff CTYPE is a struct name, e.g. (struct _GValue).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ ;; Returns #t iff ctype is a struct name, e.g. (struct _GValue).
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/struct-anon? ctype)
- ;; Returns #t iff CTYPE is an anonymous struct
- ;; -- (struct (MEMBER . TYPE)...).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ ;; Returns #t iff ctype is an anonymous struct
+ ;; -- (struct (member . type)...).
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/struct-named? ctype)
- ;; Returns #t iff CTYPE is a named struct
- ;; -- (struct NAME (MEMBER VALUE)...).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ ;; Returns #t iff ctype is a named struct
+ ;; -- (struct name (member value)...).
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-struct/name ctype)
;; This works on a struct name as well as definitions.
- (and (or (and (eq? 'STRUCT (car ctype))
+ (and (or (and (eq? 'struct (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C struct type" 'ctype-struct/name))
(symbol? (cadr ctype))
(define (make-ctype-struct name members)
(if name
- (cons* 'STRUCT name members)
- (cons 'STRUCT members)))
+ (cons* 'struct name members)
+ (cons 'struct members)))
(define (ctype/union-name? ctype)
- ;; Returns #t iff CTYPE is a union name, e.g. (union _GdkEvent).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ ;; Returns #t iff ctype is a union name, e.g. (union |_GdkEvent|).
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/union-anon? ctype)
- ;; Returns #t iff CTYPE is an anonymous union
- ;; -- (union (MEMBER . TYPE)...).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ ;; Returns #t iff ctype is an anonymous union
+ ;; -- (union (member . type)...).
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/union-named? ctype)
- ;; Returns #t iff CTYPE is a named union
- ;; -- (union NAME (MEMBER TYPE)...).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ ;; Returns #t iff ctype is a named union
+ ;; -- (union name (member type)...).
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-union/name ctype)
;; This works on union names as well as definitions.
- (and (or (and (eq? 'UNION (car ctype))
+ (and (or (and (eq? 'union (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C union type" 'ctype-union/name))
(symbol? (cadr ctype))
(define (make-ctype-union name members)
(if name
- (cons* 'UNION name members)
- (cons 'UNION members)))
+ (cons* 'union name members)
+ (cons 'union members)))
(define (ctype/enum-name? ctype)
- ;; Returns #t iff CTYPE is an enum name, e.g. (enum GdkEventType).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ ;; Returns #t iff ctype is an enum name, e.g. (enum |GdkEventType|).
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/enum-anon? ctype)
- ;; Returns #t iff CTYPE is an anonymous enum
- ;; -- (enum (CONSTANT . VALUE)...).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ ;; Returns #t iff ctype is an anonymous enum
+ ;; -- (enum (constant . value)...).
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/enum-named? ctype)
- ;; Returns #t iff CTYPE is a named enum
- ;; -- (enum NAME (CONSTANT . VALUE)...).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ ;; Returns #t iff ctype is a named enum
+ ;; -- (enum name (constant . value)...).
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-enum/name ctype)
;; This works on enum names as well as definitions.
- (and (or (and (eq? 'ENUM (car ctype))
+ (and (or (and (eq? 'enum (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C enum type" 'ctype-enum/name))
(symbol? (cadr ctype))
(define (make-ctype-enum name constants)
(if name
- (cons* 'ENUM name constants)
- (cons 'ENUM constants)))
+ (cons* 'enum name constants)
+ (cons 'enum constants)))
(define (ctype/array? ctype)
- ;; Returns #t iff CTYPE is an array type, e.g. (ARRAY (* GtkWidget) 5).
- (and (pair? ctype) (eq? 'ARRAY (car ctype))
+ ;; Returns #t iff ctype is an array type, e.g. (array (* |GtkWidget|) 5).
+ (and (pair? ctype) (eq? 'array (car ctype))
(pair? (cdr ctype))
(or (null? (cddr ctype))
(and (pair? (cddr ctype)) (null? (cdddr ctype))))))
(and (pair? (cddr ctype)) (caddr ctype)))
(define (make-ctype-array ctype size)
- (list 'ARRAY ctype size))
+ (list 'array ctype size))
(define (ctype/primitive-accessor ctype)
- ;; Returns the primitive to use when reading from CTYPE, a basic ctype.
+ ;; Returns the primitive to use when reading from ctype, a basic ctype.
(let ((entry (assq ctype peek-poke-primitives)))
(and entry
(car (cdr entry)))))
(define (ctype/primitive-modifier ctype)
- ;; Returns the primitive to use when writing to CTYPE, a basic ctype.
+ ;; Returns the primitive to use when writing to ctype, a basic ctype.
(let ((entry (assq ctype peek-poke-primitives)))
(and entry
(cadr (cdr entry)))))
;;; C Type Lookup
(define (definite-ctype ctype includes)
- ;; Returns a definite C type equivalent to CTYPE. If CTYPE is a
+ ;; Returns a definite C type equivalent to ctype. If ctype is a
;; name, e.g.
;;
;; |GdkColor|, (struct |_GdkColor|), (union |_GdkEvent|)
;;
- ;; returns the definite C type of its definition per INCLUDES. A
+ ;; returns the definite C type of its definition per includes. A
;; definite C type is a basic type name, array or pointer type, or
;; struct, union or enum names or definitions.
(ctype ctype))
(cond ((or (ctype/basic? ctype)
(ctype/void? ctype)
- (eq? 'ENUM ctype)
+ (eq? 'enum ctype)
(eq? '* ctype)) ctype)
((symbol? ctype)
(if (memq ctype stack)
(ctype/union-defn? type)
(ctype/enum-defn? type)
;; Enum constants are not enumerated in -const.scm files.
- (eq? 'ENUM type)) type)
+ (eq? 'enum type)) type)
((ctype/struct-name? type)
(let ((entry (assq (cadr type) (c-includes/structs includes))))
(if (not entry)
(define (gen-callout-trampolines includes)
(for-each
(lambda (name.alienf)
- (with-simple-restart 'CONTINUE "Continue generating callout trampolines."
+ (with-simple-restart 'continue "Continue generating callout trampolines."
(lambda ()
(bind-condition-handler
(list condition-type:simple-error)
(lambda (condition)
- (let ((restart (find-restart 'CONTINUE condition))
- (msg (access-condition condition 'MESSAGE))
- (irr (access-condition condition 'IRRITANTS)))
+ (let ((restart (find-restart 'continue condition))
+ (msg (access-condition condition 'message))
+ (irr (access-condition condition 'irritants)))
(apply warn msg irr)
(if restart
(invoke-restart restart))))
(define (new-variable root-name params)
;; Returns a name (string) for a variable that must be distinct from
- ;; those in the PARAMS alist.
+ ;; those in the params alist.
(let loop ((n 0))
(let ((name (string-append root-name (number->string n))))
(if (not (matching-param? name params))
(define (callout-part2-decls tos-var ret-var ret-ctype includes)
;; Returns a multi-line string declaring the variables to be used in
- ;; the second part of a callout trampoline. See the Owner's Manual.
+ ;; the second part of a callout trampoline. (See the FFI Manual.)
(let ((ctype (definite-ctype ret-ctype includes))
(decl (decl-string ret-ctype)))
(string-append "
(define (callout-arg-converter name arg-ctype includes)
;; Returns the name of the C function that takes an argument index
- ;; and returns it as the C type ARG-CTYPE. May have a cast
+ ;; and returns it as the C type arg-ctype. May have a cast
;; expression at the beginning. Handles args named CALLBACK and ID
;; specially.
(let ((ctype (definite-ctype arg-ctype includes))
((ctype/enum? ctype) "arg_long")
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "arg_long")
- ((UCHAR USHORT UINT ULONG) "arg_ulong")
- ((FLOAT DOUBLE) "arg_double")
+ ((char short int long) "arg_long")
+ ((uchar ushort uint ulong) "arg_ulong")
+ ((float double) "arg_double")
(else (error "Unexpected parameter type:" arg-ctype))))
((or (ctype/struct? ctype) (ctype/union? ctype))
(string-append "*("decl"*) arg_pointer"))
(define (basic-scm-converter ctype)
;; Returns the name of a C function that converts from the definite
- ;; C type CTYPE to the analogous Scheme object.
+ ;; C type ctype to the analogous Scheme object.
(cond ((ctype/enum? ctype) "ulong_to_scm")
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "long_to_scm")
- ((UCHAR USHORT UINT ULONG) "ulong_to_scm")
- ((FLOAT DOUBLE) "double_to_scm")
- ((VOID) #f)
+ ((char short int long) "long_to_scm")
+ ((uchar ushort uint ulong) "ulong_to_scm")
+ ((float double) "double_to_scm")
+ ((void) #f)
(else (error "Unexpected C type:" ctype))))
(else (error "Unexpected C type:" ctype))))
(define (callout-return-variable params)
;; Returns a name (string) for a variable that will hold the return
- ;; value. Checks for two name collisions with the PARAMS, e.g. ret0
+ ;; value. Checks for two name collisions with the params, e.g. ret0
;; and ret0s, the latter being the SCM version of the return value.
(let loop ((n 0))
(let* ((ns (number->string n))
(loop (1+ n)))))))
(define (decl-string ctype)
- ;; Returns a string in C syntax declaring the C type CTYPE.
+ ;; Returns a string in C syntax declaring the C type ctype.
;; E.g. given (* |GtkWidget|), returns "GtkWidget *".
(cond ((eq? ctype '*) "void*")
((eq? ctype 'uchar) "unsigned char")
(define (gen-callback-trampolines includes)
(for-each
(lambda (name.alienf)
- (with-simple-restart 'CONTINUE "Continue generating callback trampolines."
+ (with-simple-restart 'continue "Continue generating callback trampolines."
(lambda ()
(bind-condition-handler
(list condition-type:simple-error)
(lambda (condition)
- (let ((restart (find-restart 'CONTINUE condition))
- (msg (access-condition condition 'MESSAGE))
- (irr (access-condition condition 'IRRITANTS)))
+ (let ((restart (find-restart 'continue condition))
+ (msg (access-condition condition 'message))
+ (irr (access-condition condition 'irritants)))
(apply warn msg irr)
(if restart
(invoke-restart restart))))
(define (callback-return ret-type includes)
;; Returns a multi-line string that returns from a callback
- ;; trampoline with a value of type RET-TYPE, converted from
+ ;; trampoline with a value of type ret-type, converted from
;; val_register.
(let ((funcast (callback-return-converter ret-type includes)))
(if (not funcast) "
(define (callback-arg-cons arg-name arg-ctype includes)
;; Returns a function call that applies the appropriate Scheme
- ;; constructor to the ARG-CTYPE variable ARG-NAME.
+ ;; constructor to the arg-ctype variable arg-name.
(let ((ctype (definite-ctype arg-ctype includes)))
(cond ((ctype/pointer? ctype)
(string-append "cons_alien((void*)"arg-name")"))
(define (callback-return-converter ret-type includes)
;; Returns the name of the C function that takes no arguments and
- ;; returns the interpreter's VAL register as the C type RET-CTYPE.
+ ;; returns the interpreter's Val register as the C type ret-ctype.
(let ((ctype (definite-ctype ret-type includes)))
(cond ((ctype/pointer? ctype)
(string-append "("(decl-string ret-type)")pointer_value"))
((ctype/void? ctype) #f)
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "long_value")
- ((UCHAR USHORT UINT ULONG) "ulong_value")
- ((FLOAT DOUBLE) "double_value")
+ ((char short int long) "long_value")
+ ((uchar ushort uint ulong) "ulong_value")
+ ((float double) "double_value")
(else (error "Unexpected callback return type:" ctype))))
(else (error "Unexpected callback return type:" ctype)))))
\f
(append-map*!
(map (lambda (name.info)
;; The named structs, top-level OR internal.
- (let ((name (list 'STRUCT (car name.info))))
+ (let ((name (list 'struct (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/structs includes))
(lambda (name.info)
(append-map*!
(map (lambda (name.info)
;; The named unions, top-level OR internal.
- (let ((name (list 'UNION (car name.info))))
+ (let ((name (list 'union (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/unions includes))
(lambda (name.info)
(c-includes/type-names includes)))
(define (gen-struct-union-grovel-func name includes)
- ;; Generate C code for a grovel_NAME function.
+ ;; Generate C code for a grovel_<name> function.
(let ((fname (cond ((ctype/struct-name? name)
(string-append "grovel_struct_"
(symbol->string (ctype-struct/name name))))
(ctype (definite-ctype name includes))
(decl (decl-string name))
(_ (lambda args (for-each write-string args))))
- (let ((key (list 'SIZEOF name)))
+ (let ((key (list 'sizeof name)))
(_ "
void
"fname" (FILE * out)
(lambda (path brief-type)
(let ((path (decorated-string-append
"" "." "" (map symbol->string path)))
- (key (cons* 'OFFSET name path)))
+ (key (cons* 'offset name path)))
(_ "
fprintf (out, \" (")(write key)(_" %ld . ")(write brief-type)(_")\\n\", (long)((char*)&(S."path") - (char*)&S));"))))
(_ "
fname))
(define (for-each-member-path ctype includes receiver)
- ;; Calls RECEIVER with a path and an abbreviated type for each
- ;; member (and nested member) of the struct or union CTYPE (a C
- ;; struct or union type). Each path is a list of member names
- ;; (symbols) -- one name for immediate members, multiple names for
- ;; nested members. An abbreviated type is a Ctype, but is 'ENUM if
- ;; the actual type is (ENUM ...).
+ ;; Calls receiver with a path and an abbreviated type for each
+ ;; member (and nested member) of ctype, a C struct or union type.
+ ;; Each path is a list of member names (symbols) -- one name for
+ ;; immediate members, multiple names for nested members. An
+ ;; abbreviated type is a C type, but is 'enum if the actual type is
+ ;; (enum ...).
(let ((type (ctype-definition ctype includes)))
(cond ((ctype/struct-defn? type)
(ctype/array? ctype))
(receiver (list name) type))
((ctype/enum? ctype)
- (receiver (list name) 'ENUM))
+ (receiver (list name) 'enum))
((ctype/struct-defn? ctype)
(receiver (list name) type)
(let ((new-stack (cons type stack)))
form
(lambda (library)
(let ((ienv (senv->runtime usage-env)))
- (if (and (environment-bound? ienv 'C-INCLUDES)
- (environment-assigned? ienv 'C-INCLUDES))
- (let ((value (environment-lookup ienv 'C-INCLUDES))
+ (if (and (environment-bound? ienv 'C-includes)
+ (environment-assigned? ienv 'C-includes))
+ (let ((value (environment-lookup ienv 'C-includes))
(err (lambda (msg val)
(error (string-append
"C-includes is already bound, " msg) val))))
(c-includes/library value)))
(err "but not to a c-include structure:" value)))
(begin
- (environment-define ienv 'C-INCLUDES (load-c-includes library))
+ (environment-define ienv 'C-includes (load-c-includes library))
#f))))))))
(define (call-with-destructured-c-include-form form receiver)
- ;; Calls RECEIVER with the library.
+ ;; Calls receiver with the library.
(cond ((null? (cdr form))
(serror form "A library name is required"))
((not (string? (cadr form)))
(ctype/union-defn? type))
(if (null? member-spec)
(swarn whole-form "Cannot peek a whole struct")
- (let ((entry (assoc (cons* 'OFFSET ctype member-spec)
+ (let ((entry (assoc (cons* 'offset ctype member-spec)
(c-includes/struct-values includes))))
(if (not entry)
(swarn whole-form "No such member")
`(,prim ,alien-form ,offset ,value-form)))
((ctype/array? ctype)
(swarn whole-form "Cannot poke a whole array"))
- ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ ((or (ctype/enum? ctype) (eq? ctype 'enum))
(let ((prim (ucode-primitive c-poke-uint 3)))
`(,prim ,alien-form ,offset ,value-form)))
(else (swarn whole-form "Unexpected C type for poking" ctype))))
(swarn whole-form "Cannot peek basic type" ctype))))
((ctype/pointer? ctype)
`(,(ucode-primitive c-peek-pointer 3)
- ,alien-form ,offset ,(or value-form '(MAKE-ALIEN))))
+ ,alien-form ,offset ,(or value-form '(make-alien))))
((or (ctype/array? ctype) (ctype/struct? ctype))
(if value-form
- `(LET ((VALUE ,value-form))
- (COPY-ALIEN-ADDRESS! VALUE ,alien-form)
- (ALIEN-BYTE-INCREMENT! VALUE ,offset)
- VALUE)
- `(ALIEN-BYTE-INCREMENT ,alien-form ,offset)))
- ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ `(let ((value ,value-form))
+ (copy-alien-address! value ,alien-form)
+ (alien-byte-increment! value ,offset)
+ value)
+ `(alien-byte-increment ,alien-form ,offset)))
+ ((or (ctype/enum? ctype) (eq? ctype 'enum))
`(,(ucode-primitive c-peek-uint 2) ,alien-form ,offset))
(else (swarn whole-form "Unexpected C type for peeking" ctype))))
(define (call-with-destructured-c->-form form receiver)
- ;; Calls RECEIVER with ALIEN, SPEC and VALUE (or #f) as in these forms:
+ ;; Calls receiver with alien, spec and value (or #f) as in these forms:
;;
- ;; (C-> ALIEN SPEC) VALUE = #f
- ;; (C-> ALIEN SPEC* VALUE) SPEC* specifies a pointer-type member
- ;; (C->= ALIEN SPEC VALUE)
+ ;; (C-> alien spec) value = #f
+ ;; (C-> alien spec* value) spec* specifies a pointer-type member
+ ;; (C->= alien spec value)
;;
(let ((len (length form)))
(if (< len 3)
;; (C-enum "GDK_MAP")
;; ===> 14
;; (C-enum "GdkEventType" 14)
- ;; ===> GDK_MAP
- ;; (C-enum "GdkEventType" FORM)
- ;; ===> (C-enum-name FORM '|GdkEventType|
+ ;; ===> |GDK_MAP|
+ ;; (C-enum "GdkEventType" form)
+ ;; ===> (C-enum-name form '|GdkEventType|
;; '((|GDK_NOTHING| . -1) (|GDK_DELETE| . 0)...))
(sc-macro-transformer
(lambda (form usage-env)
(c-enum-constant-values name form includes))
(let ((value (close-syntax value-form usage-env))
(constants (c-enum-constant-values name form includes)))
- `(C-ENUM-NAME ,value ',name ',constants))))))))))
+ `(C-enum-name ,value ',name ',constants))))))))))
(define (lookup-enum-value name includes)
(let ((entry (assq name (c-includes/enum-values includes))))
(let ((name (cond ((and (string=? "enum" (car words))
(not (null? (cdr words)))
(null? (cddr words)))
- `(ENUM ,(string->symbol (cadr words))))
+ `(enum ,(string->symbol (cadr words))))
((null? (cdr words))
(string->symbol (car words)))
(else (swarn form
;; (C-sizeof "GdkColor") ===> 10
(sc-macro-transformer
(lambda (form usage-env)
- (expand-c-info-syntax 'SIZEOF form usage-env))))
+ (expand-c-info-syntax 'sizeof form usage-env))))
(define-syntax C-offset
;; (C-offset "GdkColor green") ===> 6
(sc-macro-transformer
(lambda (form usage-env)
- (expand-c-info-syntax 'OFFSET form usage-env))))
+ (expand-c-info-syntax 'offset form usage-env))))
(define (expand-c-info-syntax which form usage-env)
- ;; WHICH can be SIZEOF or OFFSET.
+ ;; which can be 'sizeof or 'offset.
(let ((len (length form)))
(if (< len 2)
(swarn form "Too few args")
(c-info which spec form usage-env))))))))
(define (c-info which spec form usage-env)
- ;; Returns the offset or sizeof for SPEC.
+ ;; Returns the offset or sizeof for spec.
(let* ((includes (find-c-includes usage-env))
(btype.members
(call-with-initial-ctype
spec form
(lambda (ctype member-spec)
(let ((defn (ctype-definition ctype includes)))
- (cond ((and (eq? which 'OFFSET) (null? member-spec))
+ (cond ((and (eq? which 'offset) (null? member-spec))
(swarn form "no member specified"))
- ((and (eq? which 'OFFSET)
+ ((and (eq? which 'offset)
(not (or (ctype/struct-defn? defn)
(ctype/union-defn? defn))))
(swarn form "not a struct or union type"))
- ((and (not (eq? which 'OFFSET)) (not (null? member-spec)))
+ ((and (not (eq? which 'offset)) (not (null? member-spec)))
(if (null? (cdr member-spec))
(swarn form "no member name allowed")
(swarn form "no member names allowed")))
(cond ((not btype.members)
form)
(entry
- (if (eq? 'OFFSET which) (cadr entry) (cdr entry)))
+ (if (eq? 'offset which) (cadr entry) (cdr entry)))
(else
- (if (eq? 'OFFSET which)
+ (if (eq? 'offset which)
(swarn form "Unknown member")
(swarn form "Unknown C type" btype.members))))))
(define (call-with-initial-ctype spec form receiver)
- ;; Given SPEC, a list of symbols, calls RECEIVER with a ctype and
+ ;; Given spec, a list of symbols, calls receiver with a ctype and
;; member spec (the list of names that followed the C type spec)
;;
- ;; For example RECEIVER is called with
+ ;; For example receiver is called with
;;
;; (* (|struct| |addrinfo|)) and (|ai_socktype|)
;;
- ;; when SPEC is (* |struct| |addrinfo| |ai_socktype|).
+ ;; when spec is (* |struct| |addrinfo| |ai_socktype|).
(let ((type-name (car spec))
(member-spec (cdr spec)))
- (cond ((memq type-name '(STRUCT UNION ENUM))
+ (cond ((memq type-name '(struct union enum))
(if (null? member-spec)
(swarn form "Incomplete C type specification")
(receiver (list type-name (car member-spec))
;;; C-array-loc and -loc! Syntaxes
(define-syntax C-array-loc
- ;; (C-array-loc ALIEN "element type" INDEX)
+ ;; (C-array-loc alien "element type" index)
;; ===>
- ;; (alien-byte-increment ALIEN (* (C-sizeof "element type") INDEX))
+ ;; (alien-byte-increment alien (* (C-sizeof "element type") index))
(sc-macro-transformer
(lambda (form usage-env)
(expand-c-array-loc-syntax #f form usage-env))))
(define-syntax C-array-loc!
- ;; (C-array-loc! ALIEN "element type" INDEX)
+ ;; (C-array-loc! alien "element type" index)
;; ===>
- ;; (alien-byte-increment! ALIEN (* (C-sizeof "element type") INDEX))
+ ;; (alien-byte-increment! alien (* (C-sizeof "element type") index))
(sc-macro-transformer
(lambda (form usage-env)
(expand-c-array-loc-syntax #t form usage-env))))
(define (expand-c-array-loc-syntax bang? form usage-env)
- (call-with-destructured-C-array-loc-form
+ (call-with-destructured-c-array-loc-form
form
(lambda (alien-form str index-form)
(let ((spec (map string->symbol (burst-string str #\space #t))))
(if (null? spec)
(swarn form "2nd arg is an empty string")
(let ((alien-form (close-syntax alien-form usage-env))
- (sizeof (c-info `SIZEOF spec form usage-env))
+ (sizeof (c-info `sizeof spec form usage-env))
(index-form (close-syntax index-form usage-env))
- (proc (if bang? 'ALIEN-BYTE-INCREMENT! 'ALIEN-BYTE-INCREMENT)))
+ (proc (if bang? 'alien-byte-increment! 'alien-byte-increment)))
`(,proc ,alien-form (* ,sizeof ,index-form))))))))
-(define (call-with-destructured-C-array-loc-form form receiver)
+(define (call-with-destructured-c-array-loc-form form receiver)
(let ((len (length form)))
(if (< len 4)
(swarn form "Too few args")
;; (call-alien #[alien-function 33 gtk_label_new] alien "Hello, World!")
(sc-macro-transformer
(lambda (form usage-env)
- (call-with-destructured-C-call-form
+ (call-with-destructured-c-call-form
form
(lambda (func-name arg-forms)
(let* ((includes (find-c-includes usage-env))
(cdr entry)
(swarn form "No declaration of callout"
func-name)))))
- `(CALL-ALIEN ,alien
+ `(call-alien ,alien
. ,(map (lambda (form) (close-syntax form usage-env))
arg-forms))))))))
-(define (call-with-destructured-C-call-form form receiver)
- ;; Calls RECEIVER with the optional return-alien-form, func-name
+(define (call-with-destructured-c-call-form form receiver)
+ ;; Calls receiver with the optional return-alien-form, func-name
;; (as a symbol), and the arg-forms.
(if (not (pair? (cdr form)))
(swarn form "No function name")
(if (pair? entry) (cdr entry)
(swarn form "No declaration of callback"))))
(let ((value-form (close-syntax obj usage-env)))
- `(REGISTER-C-CALLBACK ,value-form))))))))
+ `(register-c-callback ,value-form))))))))
(define (call-with-destructured-c-callback-form form receiver)
- ;; Calls RECEIVER with the only subform.
+ ;; Calls receiver with the only subform.
(let ((len (length form)))
(if (< len 2)
(swarn form "Too few args")
;;; Utilities
(define (find-c-includes env)
- ;; Returns the c-includes structure bound to 'C-INCLUDES in ENV.
+ ;; Returns the c-includes structure bound to 'C-includes in env.
(guarantee syntactic-environment? env 'find-c-includes)
(let ((ienv (senv->runtime env)))
- (if (and (environment-bound? ienv 'C-INCLUDES)
- (environment-assigned? ienv 'C-INCLUDES))
- (let ((includes (environment-lookup ienv 'C-INCLUDES)))
+ (if (and (environment-bound? ienv 'C-includes)
+ (environment-assigned? ienv 'C-includes))
+ (let ((includes (environment-lookup ienv 'C-includes)))
(if (c-includes? includes)
includes
(error "C-includes is not bound to a c-includes structure:"
(make-condition-type
'ffi-syntaxer-error
condition-type:error
- '(FORM MESSAGE)
+ '(form message)
(lambda (condition port)
(write-string "FFI syntax error: " port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string " in: " port)
- (write (access-condition condition 'FORM) port)
+ (write (access-condition condition 'form) port)
(write-char #\. port))))
(define serror
- (let ((signaller (condition-signaller condition-type:serror '(FORM MESSAGE)
+ (let ((signaller (condition-signaller condition-type:serror '(form message)
standard-error-handler)))
(named-lambda (serror form message . args)
(signaller form
(cons message args)))))))
(define (swarn form message . args)
- (apply warn message (append args (list 'IN form)))
+ (apply warn message (append args (list 'in form)))
`(error "Invalid syntax" ',form))
\ No newline at end of file
projects / mit-scheme.git / commitdiff