Changeset 13599 in project


Ignore:
Timestamp:
03/08/09 17:59:00 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/dollar/trunk/dollar.scm

    r13587 r13599  
    3838;;; The dollar macro
    3939
    40 (module dollar (;export
    41   $)
     40(module dollar ($)
    4241
    4342(import scheme chicken foreign)
     
    4645;;
    4746
     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) ) ) ) ) ) ) ) ) ) )
     70
     71;;
     72
    4873(define-syntax $
    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))
     
    7097                                        ($foreign-lambda* (r 'foreign-lambda*)))
    7198    (define (unknown-type-error x)
    72       (syntax-error '$ "argument is of unsupported type" x))
     99      (syntax-error '$ "argument is of unsupported type" x) )
    73100    (define (ensure-typed-atom val)
    74101      (cond ((fixnum? val)      `(,$int ,val))
     
    80107            ((eof-object? val)  `(,$scheme-object ,val))
    81108            (else
    82              (unknown-type-error val))))
     109             (unknown-type-error val)) ) )
    83110    (define (pair|vector? x)
    84       (or (pair? x) (vector? x)))
     111      (or (pair? x) (vector? x)) )
    85112    (define (ensure-typed-arg arg)
    86113      (cond ((atom? arg)
    87114             (ensure-typed-atom arg))
    88115            ((list? arg)
    89              (case (car arg)
    90                ((quote)
     116             (er-case c (car arg)
     117               (($quote)
    91118                (if (pair? (cdr arg))
    92119                    (let ((val (cadr arg)))
     
    101128                            ((f64vector? val)   `(,$nonnull-f64vector ',val))
    102129                            ((pair|vector? val) `(,$scheme-object ',val))
    103                             (else                (ensure-typed-atom val))))
     130                            (else                (ensure-typed-atom val)) ) )
    104131                    arg))
    105                ((location)
     132               (($location)
    106133                `(,$nonnull-c-pointer ,arg))
    107134               (else
    108                 (list (r (car arg)) (cadr arg)))))
     135                (list (car arg) #;(r (car arg))
     136                      (cadr arg)))))
    109137            (else
    110              (unknown-type-error arg))))
     138             (unknown-type-error arg)) ) )
    111139    (let* ((func (cadr form))
    112140           (args (cddr form))
     
    116144                           (set! args (cdr args))
    117145                           rtype))
    118                         (else $void)))
     146                        (else
     147                         $void)))
    119148           (cargs (map ensure-typed-arg args))
    120            (fargs (map (lambda (_) (gensym 'arg)) cargs)))
     149           (fargs (map
     150                   (lambda (_)
     151                     (let ((sym (r (gensym 'arg))))
     152                       (cons sym (symbol->string sym))))
     153                   cargs)))
    121154      (if (null? cargs)
    122155          (if (c $void rtype) `(,$foreign-code ,(conc func "();"))
    123156              `(,$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)))))))
     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)) ) ) ) ) )
    129163
    130164) ;module dollar
Note: See TracChangeset for help on using the changeset viewer.