(define (call-with-destructured-c-include-form form receiver)
;; Calls RECEIVER with the library.
- (if (null? (cdr form)) (serror form "a library name is required"))
- (let ((library (cadr form)))
- (if (not (string? library))
- (serror form "the 1st arg must be a string"))
- (if (not (null? (cddr form)))
- (serror form "too many args"))
- (receiver library)))
+ (cond ((null? (cdr form))
+ (serror form "A library name is required"))
+ ((not (string? (cadr form)))
+ (serror form "The 1st arg must be a string"))
+ (else
+ (if (not (null? (cddr form)))
+ (swarn form "Too many args"))
+ (receiver (cadr form)))))
(define (load-c-includes library)
(let* ((lib (merge-pathnames library (system-library-directory-pathname)))
(let ((read-modtime (cdr file.modtime))
(this-modtime (file-modification-time (car file.modtime))))
(if (and this-modtime (< read-modtime this-modtime))
- (warn "new source file:" (car file.modtime)))))
+ (warn "New source file:" (car file.modtime)))))
(c-includes/files includes)))
\f
(if poke?
(expand-poke type alien-form 0 value-form whole-form)
(expand-peek type alien-form 0 value-form whole-form))
- (let ((meta-type (cond ((ctype/basic? type) "basic")
- ((ctype/pointer? type) "pointer")
- ((ctype/array? type) "array")
- ((ctype/enum-defn? type) "enum")
- (else ""))))
- (serror whole-form meta-type " types have no members"))))
+ (let ((meta-type (cond ((ctype/basic? type) "Basic")
+ ((ctype/pointer? type) "Pointer")
+ ((ctype/array? type) "Array")
+ ((ctype/enum-defn? type) "Enum")
+ (else "?"))))
+ (swarn whole-form
+ (string-append
+ meta-type" types have no members")))))
((or (ctype/struct-defn? type)
(ctype/union-defn? type))
(if (null? member-spec)
- (serror whole-form "cannot peek a whole struct")
+ (swarn whole-form "Cannot peek a whole struct")
(let ((entry (assoc (cons* 'OFFSET ctype member-spec)
(c-includes/struct-values includes))))
- (if (not entry) (serror whole-form "no such member"))
- (let ((offset (cadr entry))
- (type (cddr entry)))
- (let ((ctype (ctype-definition type includes)))
- (if poke?
- (expand-poke ctype alien-form offset
- value-form whole-form)
- (expand-peek ctype alien-form offset
- value-form whole-form)))))))
+ (if (not entry)
+ (swarn whole-form "No such member")
+ (let ((offset (cadr entry))
+ (type (cddr entry)))
+ (let ((ctype (ctype-definition type includes)))
+ (if poke?
+ (expand-poke ctype alien-form offset
+ value-form whole-form)
+ (expand-peek ctype alien-form offset
+ value-form whole-form))))))))
(poke?
- (serror whole-form "cannot poke C type " ctype))
+ (swarn whole-form "Cannot poke C type" ctype))
(else
- (serror whole-form "cannot peek C type " ctype))))))))))
+ (swarn whole-form "Cannot peek C type" ctype))))))))))
(define (expand-poke ctype alien-form offset value-form whole-form)
- (if (not value-form) (serror whole-form "missing value (3rd) arg"))
- (cond ((ctype/basic? ctype)
- (let ((prim (or (ctype/primitive-modifier ctype)
- (serror whole-form "cannot poke basic type " ctype))))
- `(,prim ,alien-form ,offset ,value-form)))
+ (cond ((not value-form)
+ (swarn whole-form "Missing value (3rd) arg"))
+ ((ctype/basic? ctype)
+ (let ((prim (ctype/primitive-modifier ctype)))
+ (if prim
+ `(,prim ,alien-form ,offset ,value-form)
+ (swarn whole-form "Cannot poke basic type" ctype))))
((ctype/pointer? ctype)
(let ((prim (ucode-primitive c-poke-pointer 3)))
`(,prim ,alien-form ,offset ,value-form)))
((ctype/array? ctype)
- (serror whole-form "cannot poke a whole array"))
+ (swarn whole-form "Cannot poke a whole array"))
((or (ctype/enum? ctype) (eq? ctype 'ENUM))
(let ((prim (ucode-primitive c-poke-uint 3)))
`(,prim ,alien-form ,offset ,value-form)))
- (else (error "unexpected C type for poking" ctype))))
+ (else (swarn whole-form "Unexpected C type for poking" ctype))))
(define (expand-peek ctype alien-form offset value-form whole-form)
(cond ((ctype/basic? ctype)
- (if value-form (serror whole-form "ignoring extra (3rd) arg"))
- (let ((prim (or (ctype/primitive-accessor ctype)
- (serror whole-form "cannot peek basic type " ctype))))
- `(,prim ,alien-form ,offset)))
+ (if value-form (swarn whole-form "Ignoring extra (3rd) arg"))
+ (let ((prim (ctype/primitive-accessor ctype)))
+ (if prim
+ `(,prim ,alien-form ,offset)
+ (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-BYTE-INCREMENT ,alien-form ,offset)))
((or (ctype/enum? ctype) (eq? ctype 'ENUM))
`(,(ucode-primitive c-peek-uint 2) ,alien-form ,offset))
- (else (error "unexpected C type for peeking" ctype))))
+ (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:
;; (C->= ALIEN SPEC VALUE)
;;
(let ((len (length form)))
- (if (< len 3) (serror form "too few args"))
- (if (> len 4) (serror form "too many args"))
- (let ((alien-form (cadr form))
- (type-member-spec (caddr form))
- (value-form (and (= 4 len) (cadddr form))))
- (if (not (string? type-member-spec))
- (serror form "2nd arg must be a string"))
- (let ((type-member-spec (map string->symbol
- (burst-string type-member-spec #\space #t))))
- (if (null? type-member-spec)
- (serror form "2nd arg is an empty string"))
- (receiver alien-form type-member-spec value-form)))))
+ (if (< len 3)
+ (swarn form "Too few args")
+ (let ((alien-form (cadr form))
+ (type-member-spec (caddr form))
+ (value-form (and (= 4 len) (cadddr form))))
+ (if (< 4 len) (swarn form "Too many args"))
+ (if (not (string? type-member-spec))
+ (swarn form "2nd arg must be a string")
+ (let ((type-member-spec
+ (map string->symbol
+ (burst-string type-member-spec #\space #t))))
+ (if (null? type-member-spec)
+ (swarn form "2nd arg is an empty string")
+ (receiver alien-form type-member-spec value-form))))))))
\f
;;; C-enum Syntax
(define (lookup-enum-value name includes)
(let ((entry (assq name (c-includes/enum-values includes))))
(if (not entry)
- (begin
- (warn "no declaration of constant:" name)
- 0)
+ (swarn name "No declaration of constant")
(cdr entry))))
(define (c-enum-constant-values name form includes)
(if (pair? consts)
(let* ((name (caar consts))
(entry (or (assq name vals)
- (error "no value for enum constant" name))))
+ (begin
+ (swarn form "No value for enum constant")
+ (cons name #f)))))
(cons entry (loop (cdr consts))))
'()))
- (serror form "not an enum type"))))
+ (swarn form "Not an enum type"))))
(define (call-with-destructured-c-enum-form form receiver)
(let ((len (length form)))
- (if (< len 2) (serror form "too few args"))
- (if (> len 3) (serror form "too many args"))
- (let ((type-str (cadr form))
- (value-form (and (pair? (cddr form)) (caddr form))))
- (if (not (string? type-str))
- (serror form "1st arg must be a string"))
- (let ((words (burst-string type-str #\space #t)))
- (if (null? words)
- (serror form "1st arg is an empty string"))
- (let ((name (cond ((and (string=? "enum" (car words))
- (not (null? (cdr words)))
- (null? (cddr words)))
- `(ENUM ,(string->symbol (cadr words))))
- ((null? (cdr words))
- (string->symbol (car words)))
- (else (serror form "not an enum type name")))))
- (if (and value-form (string? value-form))
- (serror form "2nd arg cannot be a string"))
- (receiver name value-form))))))
+ (if (< len 2)
+ (swarn form "Too few args")
+ (let ((type-str (cadr form))
+ (value-form (and (pair? (cddr form)) (caddr form))))
+ (if (< 3 len) (swarn form "Too many args"))
+ (if (not (string? type-str))
+ (swarn form "1st arg must be a string")
+ (let ((words (burst-string type-str #\space #t)))
+ (if (null? words)
+ (swarn form "1st arg is an empty string")
+ (let ((name (cond ((and (string=? "enum" (car words))
+ (not (null? (cdr words)))
+ (null? (cddr words)))
+ `(ENUM ,(string->symbol (cadr words))))
+ ((null? (cdr words))
+ (string->symbol (car words)))
+ (else (swarn form
+ "Not an enum type name")))))
+ (if (and value-form (string? value-form))
+ (swarn form "2nd arg cannot be a string")
+ (receiver name value-form))))))))))
\f
;;; C-sizeof and C-offset Syntaxes
(define (expand-c-info-syntax which form usage-env)
;; WHICH can be SIZEOF or OFFSET.
(let ((len (length form)))
- (if (< len 2) (serror form "too few args"))
- (if (> len 2) (serror form "too many args"))
- (let ((str (cadr form)))
- (if (not (string? str)) (serror form "arg must be a string"))
- (let ((spec (map string->symbol (burst-string str #\space #t))))
- (if (null? spec) (serror form "arg is an empty string"))
- (c-info which spec form usage-env)))))
+ (if (< len 2)
+ (swarn form "Too few args")
+ (let ((str (cadr form)))
+ (if (< 2 len) (swarn form "Too many args"))
+ (if (not (string? str))
+ (swarn form "Arg must be a string")
+ (let ((spec (map string->symbol (burst-string str #\space #t))))
+ (if (null? spec)
+ (swarn form "arg is an empty string")
+ (c-info which spec form usage-env))))))))
(define (c-info which spec form usage-env)
;; Returns the offset or sizeof for SPEC.
spec form
(lambda (ctype member-spec)
(let ((defn (ctype-definition ctype includes)))
- (if (and (eq? which 'OFFSET) (null? member-spec))
- (serror form "no member specified"))
- (if (and (eq? which 'OFFSET)
- (not (or (ctype/struct-defn? defn)
- (ctype/union-defn? defn))))
- (serror form "not a struct or union type"))
- (if (and (not (eq? which 'OFFSET)) (not (null? member-spec)))
- (if (null? (cdr member-spec))
- (serror form "no member name allowed")
- (serror form "no member names allowed")))
- (cond ((ctype/basic? defn)
+ (cond ((and (eq? which 'OFFSET) (null? member-spec))
+ (swarn form "no member specified"))
+ ((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)))
+ (if (null? (cdr member-spec))
+ (swarn form "no member name allowed")
+ (swarn form "no member names allowed")))
+ ((ctype/basic? defn)
(cons defn '()))
((ctype/pointer? defn)
(cons '* '()))
(cons ctype member-spec))
(else
(serror form "unimplemented")))))))
- (entry (assoc (cons which btype.members)
- (c-includes/struct-values includes))))
- (if entry
- (if (eq? 'OFFSET which) (cadr entry) (cdr entry))
- (if (eq? 'OFFSET which)
- (serror form "unknown member")
- (serror form "unknown C type " btype.members)))))
+ (entry (and btype.members
+ (assoc (cons which btype.members)
+ (c-includes/struct-values includes)))))
+ (cond ((not btype.members)
+ form)
+ (entry
+ (if (eq? 'OFFSET which) (cadr entry) (cdr entry)))
+ (else
+ (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
(member-spec (cdr spec)))
(cond ((memq type-name '(STRUCT UNION ENUM))
(if (null? member-spec)
- (serror form "incomplete C type specification")
+ (swarn form "Incomplete C type specification")
(receiver (list type-name (car member-spec))
(cdr member-spec))))
((eq? type-name '*)
form
(lambda (alien-form str index-form)
(let ((spec (map string->symbol (burst-string str #\space #t))))
- (if (null? spec) (serror form "2nd arg is an empty string"))
- (let ((alien-form (close-syntax alien-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 ,alien-form (* ,sizeof ,index-form)))))))
+ (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))
+ (index-form (close-syntax index-form usage-env))
+ (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)
(let ((len (length form)))
- (if (< len 4) (serror form "too few args"))
- (if (> len 4) (serror form "too many args"))
- (let ((alien-form (cadr form))
- (type (if (string? (caddr form))
- (caddr form)
- (serror form "the 2nd arg must be a string")))
- (index-form (cadddr form)))
- (receiver alien-form type index-form))))
+ (if (< len 4)
+ (swarn form "Too few args")
+ (let ((alien-form (cadr form))
+ (type (caddr form))
+ (index-form (cadddr form)))
+ (if (> len 4) (swarn form "Too many args"))
+ (if (not (string? type))
+ (swarn form "The 2nd arg must be a string")
+ (receiver alien-form type index-form))))))
\f
;;; C-call Syntax
(alien (let ((entry (assq func-name callouts)))
(if (pair? entry)
(cdr entry)
- (begin
- (warn "no declaration of callout:" func-name)
- func-name)))))
+ (swarn form "No declaration of callout"
+ func-name)))))
`(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
;; (as a symbol), and the arg-forms.
- (if (not (pair? (cdr form))) (serror form "no function name"))
- (let ((name (cadr form))
- (args (cddr form)))
- (if (not (string? name)) (serror form "first arg is not a string"))
- (receiver (string->symbol name) args)))
+ (if (not (pair? (cdr form)))
+ (swarn form "No function name")
+ (let ((name (cadr form))
+ (args (cddr form)))
+ (if (not (string? name))
+ (swarn form "First arg must be a string")
+ (receiver (string->symbol name) args)))))
\f
;;; C-callback Syntax
(name (string->symbol obj)))
(let ((entry (assq name callbacks)))
(if (pair? entry) (cdr entry)
- (begin
- (warn "no declaration of callback:" name)
- name))))
+ (swarn form "No declaration of callback"))))
(let ((value-form (close-syntax obj usage-env)))
`(REGISTER-C-CALLBACK ,value-form))))))))
(define (call-with-destructured-c-callback-form form receiver)
;; Calls RECEIVER with the only subform.
(let ((len (length form)))
- (if (< len 2) (serror form "too few args"))
- (if (> len 2) (serror form "too many args"))
- (receiver (cadr form))))
+ (if (< len 2)
+ (swarn form "Too few args")
+ (begin
+ (if (< 2 len)
+ (swarn form "Too many args")
+ (receiver (cadr form)))))))
\f
;;; Utilities
(apply string-append
(map (lambda (obj)
(if (string? obj) obj (write-to-string obj)))
- (cons message args)))))))
\ No newline at end of file
+ (cons message args)))))))
+
+(define (swarn form message . args)
+ (apply warn message (append args (list 'IN form)))
+ `(error "Invalid syntax" ',form))
\ No newline at end of file
projects / mit-scheme.git / commitdiff