From 03118f51e034355836f4f4bfabcc6b14e886ec84 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Tue, 6 Aug 2019 15:33:34 -0700 Subject: [PATCH] ffi: downcase symbols, most names --- src/ffi/cdecls.scm | 100 +++++++++++++++++------------------ src/ffi/ctypes.scm | 92 ++++++++++++++++---------------- src/ffi/generator.scm | 78 ++++++++++++++-------------- src/ffi/syntax.scm | 118 +++++++++++++++++++++--------------------- 4 files changed, 194 insertions(+), 194 deletions(-) diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm index 95411dd6e..0bfd9d994 100644 --- a/src/ffi/cdecls.scm +++ b/src/ffi/cdecls.scm @@ -57,7 +57,7 @@ USA. (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)) @@ -70,9 +70,9 @@ USA. (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") @@ -114,8 +114,8 @@ USA. (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")) @@ -136,7 +136,7 @@ USA. 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")) @@ -149,13 +149,13 @@ USA. 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))) @@ -165,8 +165,8 @@ USA. 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")) @@ -175,13 +175,13 @@ USA. (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))) @@ -191,8 +191,8 @@ USA. 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")) @@ -201,15 +201,15 @@ USA. (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! @@ -217,16 +217,16 @@ USA. (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 @@ -245,14 +245,14 @@ USA. (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))) @@ -265,20 +265,20 @@ USA. (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)))) @@ -295,40 +295,40 @@ USA. 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))) @@ -338,18 +338,18 @@ USA. (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 @@ -362,20 +362,20 @@ USA. (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 diff --git a/src/ffi/ctypes.scm b/src/ffi/ctypes.scm index 27293a797..a78086237 100644 --- a/src/ffi/ctypes.scm +++ b/src/ffi/ctypes.scm @@ -31,13 +31,13 @@ USA. ;;; 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))))) @@ -45,30 +45,30 @@ USA. (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)))) @@ -86,7 +86,7 @@ USA. (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)) @@ -94,25 +94,25 @@ USA. (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)))) @@ -130,7 +130,7 @@ USA. (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)) @@ -138,25 +138,25 @@ USA. (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)))) @@ -174,7 +174,7 @@ USA. (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)) @@ -182,12 +182,12 @@ USA. (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)))))) @@ -198,16 +198,16 @@ USA. (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))))) @@ -234,12 +234,12 @@ USA. ;;; 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. @@ -247,7 +247,7 @@ USA. (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) @@ -276,7 +276,7 @@ USA. (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) diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm index c22e87909..f848e27df 100644 --- a/src/ffi/generator.scm +++ b/src/ffi/generator.scm @@ -79,14 +79,14 @@ USA. (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)))) @@ -152,7 +152,7 @@ Scm_"name" (void) (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)) @@ -163,7 +163,7 @@ Scm_"name" (void) (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 " @@ -268,7 +268,7 @@ Scm_"name" (void) (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)) @@ -282,9 +282,9 @@ Scm_"name" (void) ((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")) @@ -292,20 +292,20 @@ Scm_"name" (void) (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)) @@ -319,7 +319,7 @@ Scm_"name" (void) (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") @@ -348,14 +348,14 @@ Scm_"name" (void) (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)))) @@ -463,7 +463,7 @@ Scm_"name" ("arglist") (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) " @@ -473,7 +473,7 @@ Scm_"name" ("arglist") (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")")) @@ -487,7 +487,7 @@ Scm_"name" ("arglist") (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")) @@ -495,9 +495,9 @@ Scm_"name" ("arglist") ((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))))) @@ -590,7 +590,7 @@ grovel_enums (FILE * out) (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) @@ -607,7 +607,7 @@ grovel_enums (FILE * out) (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) @@ -620,7 +620,7 @@ grovel_enums (FILE * out) (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_ function. (let ((fname (cond ((ctype/struct-name? name) (string-append "grovel_struct_" (symbol->string (ctype-struct/name name)))) @@ -633,7 +633,7 @@ grovel_enums (FILE * out) (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) @@ -645,7 +645,7 @@ void (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));")))) (_ " @@ -654,12 +654,12 @@ void 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) @@ -688,7 +688,7 @@ void (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))) diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm index d08a90314..55ce14025 100644 --- a/src/ffi/syntax.scm +++ b/src/ffi/syntax.scm @@ -38,9 +38,9 @@ USA. 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)))) @@ -51,11 +51,11 @@ USA. (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))) @@ -143,7 +143,7 @@ USA. (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") @@ -173,7 +173,7 @@ USA. `(,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)))) @@ -187,24 +187,24 @@ USA. (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) @@ -229,9 +229,9 @@ USA. ;; (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) @@ -246,7 +246,7 @@ USA. (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)))) @@ -284,7 +284,7 @@ USA. (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 @@ -300,16 +300,16 @@ USA. ;; (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") @@ -323,20 +323,20 @@ USA. (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"))) @@ -355,24 +355,24 @@ USA. (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)) @@ -393,35 +393,35 @@ USA. ;;; 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") @@ -442,7 +442,7 @@ USA. ;; (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)) @@ -452,12 +452,12 @@ USA. (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") @@ -486,10 +486,10 @@ USA. (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") @@ -502,12 +502,12 @@ USA. ;;; 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:" @@ -518,16 +518,16 @@ USA. (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 @@ -537,5 +537,5 @@ USA. (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 -- 2.25.1