suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 3da4f462b6157310f4709fb18531948c6223c3a8
This commit is contained in:
Eli Barzilay 2004-06-17 09:25:14 +00:00
parent 04712cc440
commit efa6e5a354
1 changed files with 22 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/mzlib/foreign.ss
View File

@ -410,7 +410,8 @@
;; Call this with a name (symbol) and a list of symbols, where a symbol can be ;; Call this with a name (symbol) and a list of symbols, where a symbol can be
;; followed by a '= and an integer to have a similar effect of C's enum. ;; followed by a '= and an integer to have a similar effect of C's enum.
(define (_enum* name symbols) (define (_enum* name symbols . base?)
(define basetype (if (pair? base?) (car base?) _ufixint))
(define sym->int '()) (define sym->int '())
(define int->sym '()) (define int->sym '())
(define s->c (define s->c
@ -425,7 +426,7 @@
(set! sym->int (cons (cons (car symbols) i) sym->int)) (set! sym->int (cons (cons (car symbols) i) sym->int))
(set! int->sym (cons (cons i (car symbols)) int->sym)) (set! int->sym (cons (cons i (car symbols)) int->sym))
(loop (add1 i) (cdr symbols)))) (loop (add1 i) (cdr symbols))))
(make-ctype _int (make-ctype basetype
(lambda (x) (lambda (x)
(let ([a (assq x sym->int)]) (let ([a (assq x sym->int)])
(if a (if a
@ -437,15 +438,21 @@
(provide _enum) (provide _enum)
(define-syntax (_enum stx) (define-syntax (_enum stx)
(syntax-case stx () (syntax-case stx ()
[(_ syms) (with-syntax ([name (syntax-local-name)]) [(_ syms)
#'(_enum* 'name syms))] (with-syntax ([name (syntax-local-name)])
[id (identifier? #'id) #'(lambda (syms) (_enum* #f syms))])) #'(_enum* 'name syms))]
[(_ syms basetype)
(with-syntax ([name (syntax-local-name)])
#'(_enum* 'name syms basetype))]
[id (identifier? #'id)
#'(lambda (syms . base?) (apply _enum* #f syms base?))]))
;; Call this with a name (symbol) and a list of (symbol int) or symbols like ;; Call this with a name (symbol) and a list of (symbol int) or symbols like
;; the above with '= -- but the numbers have to be specified in some way. The ;; the above with '= -- but the numbers have to be specified in some way. The
;; generated type will convert a list of these symbols into the logical-or of ;; generated type will convert a list of these symbols into the logical-or of
;; their values and back. ;; their values and back.
(define (_bitmask* name symbols->integers) (define (_bitmask* name symbols->integers . base?)
(define basetype (if (pair? base?) (car base?) _uint))
(define s->c (define s->c
(if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
(let loop ([s->i symbols->integers]) (let loop ([s->i symbols->integers])
@ -457,7 +464,7 @@
(symbol? (caar s->i)) (integer? (cadar s->i))) (symbol? (caar s->i)) (integer? (cadar s->i)))
(error '_bitmask "bad spec in ~e" symbols->integers)) (error '_bitmask "bad spec in ~e" symbols->integers))
(loop (cdr s->i)))) (loop (cdr s->i))))
(make-ctype _int (make-ctype basetype
(lambda (symbols) (lambda (symbols)
(if (null? symbols) ; probably common (if (null? symbols) ; probably common
0 0
@ -483,9 +490,14 @@
(provide _bitmask) (provide _bitmask)
(define-syntax (_bitmask stx) (define-syntax (_bitmask stx)
(syntax-case stx () (syntax-case stx ()
[(_ syms) (with-syntax ([name (syntax-local-name)]) [(_ syms)
#'(_bitmask* 'name syms))] (with-syntax ([name (syntax-local-name)])
[id (identifier? #'id) #'(lambda (syms) (_bitmask* #f syms))])) #'(_bitmask* 'name syms))]
[(_ syms basetype)
(with-syntax ([name (syntax-local-name)])
#'(_bitmask* 'name syms basetype))]
[id (identifier? #'id)
#'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Custom function type macros ;; Custom function type macros