Changeset 13843 in project


Ignore:
Timestamp:
03/19/09 23:20:31 (11 years ago)
Author:
Kon Lovett
Message:

Seems to work, at least w/ macosx egg.

Location:
release/4/dollar
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/dollar/tags/2.0.0/dollar.scm

    r13587 r13843  
    3838;;; The dollar macro
    3939
    40 (module dollar (;export
    41   $)
     40(module dollar ($)
    4241
    43 (import scheme chicken foreign)
    44 (import srfi-4)
     42(import scheme chicken foreign srfi-4)
     43
     44;;
     45
     46#;
     47(define-syntax er-case
     48  (lambda (form r c)
     49    (##sys#check-syntax 'er-case form '(_ variable _ . #(_ 0)))
     50    (let ((cmp (cadr form))
     51          (exp (caddr form))
     52          (body (cdddr form)))
     53      (let ((tmp (r 'tmp))
     54            (%begin (r 'begin))
     55            (%if (r 'if))
     56            (%or (r 'or))
     57            (%else (r 'else)))
     58        `(let ((,tmp ,exp))
     59           ,(let expand ((clauses body))
     60              (if (not (pair? clauses))
     61                  '(void)
     62                  (let ((clause (car clauses))
     63                        (rclauses (cdr clauses)) )
     64                    (##sys#check-syntax 'er-case clause '#(_ 1))
     65                    (if (c %else (car clause))
     66                        `(,%begin ,@(cdr clause))
     67                        `(,%if (,%or ,@(map (lambda (x) `(,cmp ,tmp ,x)) (car clause)))
     68                               (,%begin ,@(cdr clause))
     69                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
    4570
    4671;;
     
    4974  (lambda (form r c)
    5075    (##sys#check-syntax '$ form '(_ symbol . #(_ 0)))
    51     (let (($void (r 'void))
     76    (let (($quote (r 'quote))
     77          ($location (r 'location))
     78                                        ($void (r 'void))
    5279                                        ($bool (r 'bool))
    5380                                        ($char (r 'char))
     
    6996                                        ($foreign-value (r 'foreign-value))
    7097                                        ($foreign-lambda* (r 'foreign-lambda*)))
     98
    7199    (define (unknown-type-error x)
    72       (syntax-error '$ "argument is of unsupported type" x))
     100      (syntax-error '$ "bad argument type - unsupported" x) )
     101
    73102    (define (ensure-typed-atom val)
    74103      (cond ((fixnum? val)      `(,$int ,val))
     
    80109            ((eof-object? val)  `(,$scheme-object ,val))
    81110            (else
    82              (unknown-type-error val))))
     111             (unknown-type-error val)) ) )
     112
    83113    (define (pair|vector? x)
    84       (or (pair? x) (vector? x)))
     114      (or (pair? x) (vector? x)) )
     115
    85116    (define (ensure-typed-arg arg)
    86       (cond ((atom? arg)
    87              (ensure-typed-atom arg))
     117      (cond ((atom? arg) (ensure-typed-atom arg))
    88118            ((list? arg)
    89              (case (car arg)
    90                ((quote)
    91                 (if (pair? (cdr arg))
    92                     (let ((val (cadr arg)))
    93                       (cond ((symbol? val)      `(,$symbol ',val))
    94                             ((u8vector? val)    `(,$nonnull-u8vector ',val))
    95                             ((s8vector? val)    `(,$nonnull-s8vector ',val))
    96                             ((u16vector? val)   `(,$nonnull-u16vector ',val))
    97                             ((s16vector? val)   `(,$nonnull-s16vector ',val))
    98                             ((u32vector? val)   `(,$nonnull-u32vector ',val))
    99                             ((s32vector? val)   `(,$nonnull-s32vector ',val))
    100                             ((f32vector? val)   `(,$nonnull-f32vector ',val))
    101                             ((f64vector? val)   `(,$nonnull-f64vector ',val))
    102                             ((pair|vector? val) `(,$scheme-object ',val))
    103                             (else                (ensure-typed-atom val))))
    104                     arg))
    105                ((location)
    106                 `(,$nonnull-c-pointer ,arg))
    107                (else
    108                 (list (r (car arg)) (cadr arg)))))
     119             (let ((typ (car arg)))
     120               (cond ((c $quote typ)
     121                      (if (not (pair? (cdr arg))) arg
     122                          (let ((val (cadr arg)))
     123                            (cond ((symbol? val)      `(,$symbol ',val))
     124                                  ((u8vector? val)    `(,$nonnull-u8vector ',val))
     125                                  ((s8vector? val)    `(,$nonnull-s8vector ',val))
     126                                  ((u16vector? val)   `(,$nonnull-u16vector ',val))
     127                                  ((s16vector? val)   `(,$nonnull-s16vector ',val))
     128                                  ((u32vector? val)   `(,$nonnull-u32vector ',val))
     129                                  ((s32vector? val)   `(,$nonnull-s32vector ',val))
     130                                  ((f32vector? val)   `(,$nonnull-f32vector ',val))
     131                                  ((f64vector? val)   `(,$nonnull-f64vector ',val))
     132                                  ((pair|vector? val) `(,$scheme-object ',val))
     133                                  (else                (ensure-typed-atom val) ) ) ) ) )
     134                     ((c $location typ) `(,$nonnull-c-pointer ,arg))
     135                     ((not (pair? (cdr arg))) (ensure-typed-atom arg))
     136                     (else (list (r typ) (cadr arg)) ) ) ) )
    109137            (else
    110              (unknown-type-error arg))))
     138             (unknown-type-error arg) ) ) )
     139
     140    (define (genarg _)
     141      (let ((sym (r (gensym 'arg))))
     142        (cons sym (symbol->string sym)) ) )
     143
     144    ; Note - `rtype' is NOT renamed!
    111145    (let* ((func (cadr form))
    112146           (args (cddr form))
     
    118152                        (else $void)))
    119153           (cargs (map ensure-typed-arg args))
    120            (fargs (map (lambda (_) (gensym 'arg)) cargs)))
    121       (if (null? cargs)
    122           (if (c $void rtype) `(,$foreign-code ,(conc func "();"))
    123               `(,$foreign-value ,(conc func "()") ,rtype))
    124           `((,$foreign-lambda* ,rtype
    125                                ,(map (lambda (arg sym) (list (r (car arg)) sym)) cargs fargs)
    126               ,(let ((body (conc func #\( (string-intersperse (map ->string fargs) ",") #\))))
    127                  (conc (if (c $void rtype) body (string-append "C_return( " body ")")) #\;)))
    128             ,@(map cadr cargs)))))))
     154           (fargs (map genarg cargs) ) )
     155      (cond ((not (null? cargs))
     156             `((,$foreign-lambda*
     157                ,rtype
     158                ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
     159                ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
     160                   (conc (if (c $void rtype) body (string-append "return(" body ")")) #\;)))
     161               ,@(map cadr cargs)) )
     162            ((c $void rtype)
     163             `(,$foreign-code ,(conc func #\( #\) #\;) ,rtype))
     164            (else
     165             `(,$foreign-value ,(conc func #\( #\)) ,rtype) ) ) ) ) ) )
    129166
    130167) ;module dollar
  • release/4/dollar/trunk/dollar.scm

    r13599 r13843  
    4040(module dollar ($)
    4141
    42 (import scheme chicken foreign)
    43 (import srfi-4)
     42(import scheme chicken foreign srfi-4)
    4443
    4544;;
    4645
     46#;
    4747(define-syntax er-case
    4848  (lambda (form r c)
     
    6666                        `(,%begin ,@(cdr clause))
    6767                        `(,%if (,%or ,@(map (lambda (x) `(,cmp ,tmp ,x)) (car clause)))
    68                                (,%begin ,@(cdr clause)) 
     68                               (,%begin ,@(cdr clause))
    6969                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
    7070
     
    9696                                        ($foreign-value (r 'foreign-value))
    9797                                        ($foreign-lambda* (r 'foreign-lambda*)))
     98
    9899    (define (unknown-type-error x)
    99       (syntax-error '$ "argument is of unsupported type" x) )
     100      (syntax-error '$ "bad argument type - unsupported" x) )
     101
    100102    (define (ensure-typed-atom val)
    101103      (cond ((fixnum? val)      `(,$int ,val))
     
    108110            (else
    109111             (unknown-type-error val)) ) )
     112
    110113    (define (pair|vector? x)
    111114      (or (pair? x) (vector? x)) )
     115
    112116    (define (ensure-typed-arg arg)
    113       (cond ((atom? arg)
    114              (ensure-typed-atom arg))
     117      (cond ((atom? arg) (ensure-typed-atom arg))
    115118            ((list? arg)
    116              (er-case c (car arg)
    117                (($quote)
    118                 (if (pair? (cdr arg))
    119                     (let ((val (cadr arg)))
    120                       (cond ((symbol? val)      `(,$symbol ',val))
    121                             ((u8vector? val)    `(,$nonnull-u8vector ',val))
    122                             ((s8vector? val)    `(,$nonnull-s8vector ',val))
    123                             ((u16vector? val)   `(,$nonnull-u16vector ',val))
    124                             ((s16vector? val)   `(,$nonnull-s16vector ',val))
    125                             ((u32vector? val)   `(,$nonnull-u32vector ',val))
    126                             ((s32vector? val)   `(,$nonnull-s32vector ',val))
    127                             ((f32vector? val)   `(,$nonnull-f32vector ',val))
    128                             ((f64vector? val)   `(,$nonnull-f64vector ',val))
    129                             ((pair|vector? val) `(,$scheme-object ',val))
    130                             (else                (ensure-typed-atom val)) ) )
    131                     arg))
    132                (($location)
    133                 `(,$nonnull-c-pointer ,arg))
    134                (else
    135                 (list (car arg) #;(r (car arg))
    136                       (cadr arg)))))
     119             (let ((typ (car arg)))
     120               (cond ((c $quote typ)
     121                      (if (not (pair? (cdr arg))) arg
     122                          (let ((val (cadr arg)))
     123                            (cond ((symbol? val)      `(,$symbol ',val))
     124                                  ((u8vector? val)    `(,$nonnull-u8vector ',val))
     125                                  ((s8vector? val)    `(,$nonnull-s8vector ',val))
     126                                  ((u16vector? val)   `(,$nonnull-u16vector ',val))
     127                                  ((s16vector? val)   `(,$nonnull-s16vector ',val))
     128                                  ((u32vector? val)   `(,$nonnull-u32vector ',val))
     129                                  ((s32vector? val)   `(,$nonnull-s32vector ',val))
     130                                  ((f32vector? val)   `(,$nonnull-f32vector ',val))
     131                                  ((f64vector? val)   `(,$nonnull-f64vector ',val))
     132                                  ((pair|vector? val) `(,$scheme-object ',val))
     133                                  (else                (ensure-typed-atom val) ) ) ) ) )
     134                     ((c $location typ) `(,$nonnull-c-pointer ,arg))
     135                     ((not (pair? (cdr arg))) (ensure-typed-atom arg))
     136                     (else (list (r typ) (cadr arg)) ) ) ) )
    137137            (else
    138              (unknown-type-error arg)) ) )
     138             (unknown-type-error arg) ) ) )
     139
     140    (define (genarg _)
     141      (let ((sym (r (gensym 'arg))))
     142        (cons sym (symbol->string sym)) ) )
     143
     144    ; Note - `rtype' is NOT renamed!
    139145    (let* ((func (cadr form))
    140146           (args (cddr form))
     
    144150                           (set! args (cdr args))
    145151                           rtype))
    146                         (else
    147                          $void)))
     152                        (else $void)))
    148153           (cargs (map ensure-typed-arg args))
    149            (fargs (map
    150                    (lambda (_)
    151                      (let ((sym (r (gensym 'arg))))
    152                        (cons sym (symbol->string sym))))
    153                    cargs)))
    154       (if (null? cargs)
    155           (if (c $void rtype) `(,$foreign-code ,(conc func "();"))
    156               `(,$foreign-value ,(conc func "()") ,rtype))
    157           `((,$foreign-lambda*
    158              ,rtype
    159              ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
    160              ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
    161                 (conc (if (c $void rtype) body (string-append "C_return( " body ")")) #\;)))
    162             ,@(map cadr cargs)) ) ) ) ) )
     154           (fargs (map genarg cargs) ) )
     155      (cond ((not (null? cargs))
     156             `((,$foreign-lambda*
     157                ,rtype
     158                ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
     159                ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
     160                   (conc (if (c $void rtype) body (string-append "return(" body ")")) #\;)))
     161               ,@(map cadr cargs)) )
     162            ((c $void rtype)
     163             `(,$foreign-code ,(conc func #\( #\) #\;) ,rtype))
     164            (else
     165             `(,$foreign-value ,(conc func #\( #\)) ,rtype) ) ) ) ) ) )
    163166
    164167) ;module dollar
Note: See TracChangeset for help on using the changeset viewer.