;;;; dollar.scm
;;;; Kon Lovett, Mar '09
;
; Copyright (c) 2006, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to:
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany

;;; The dollar macro

(module dollar ($)

(import scheme chicken foreign)

(require-library srfi-4)
(import-for-syntax srfi-4)

;;

#;
(define-syntax er-case
  (lambda (form r c)
    (##sys#check-syntax 'er-case form '(_ variable _ . #(_ 0)))
    (let ((cmp (cadr form))
          (exp (caddr form))
          (body (cdddr form)))
      (let ((tmp (r 'tmp))
            (%begin (r 'begin))
            (%if (r 'if))
            (%or (r 'or))
            (%else (r 'else)))
        `(let ((,tmp ,exp))
           ,(let expand ((clauses body))
              (if (not (pair? clauses))
                  '(void)
                  (let ((clause (car clauses))
                        (rclauses (cdr clauses)) )
                    (##sys#check-syntax 'er-case clause '#(_ 1))
                    (if (c %else (car clause))
                        `(,%begin ,@(cdr clause))
                        `(,%if (,%or ,@(map (lambda (x) `(,cmp ,tmp ,x)) (car clause)))
                               (,%begin ,@(cdr clause))
                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) )

;;

(define-syntax $
  (lambda (form r c)
    (##sys#check-syntax '$ form '(_ symbol . #(_ 0)))
    (let (($quote (r 'quote))
          ($location (r 'location))
					($void (r 'void))
					($bool (r 'bool))
					($char (r 'char))
					($int (r 'int))
					($double (r 'double))
					($symbol (r 'symbol))
					($scheme-object (r 'scheme-object))
					($nonnull-c-string (r 'nonnull-c-string))
					($nonnull-c-pointer (r 'nonnull-c-pointer))
					($nonnull-u8vector (r 'nonnull-u8vector))
					($nonnull-s8vector (r 'nonnull-s8vector))
					($nonnull-u16vector (r 'nonnull-u16vector))
					($nonnull-s16vector (r 'nonnull-s16vector))
					($nonnull-u32vector (r 'nonnull-u32vector))
					($nonnull-s32vector (r 'nonnull-s32vector))
					($nonnull-f32vector (r 'nonnull-f32vector))
					($nonnull-f64vector (r 'nonnull-f64vector))
          ($foreign-code (r 'foreign-code))
					($foreign-value (r 'foreign-value))
					($foreign-lambda* (r 'foreign-lambda*)))

    (define (unknown-type-error x)
      (syntax-error '$ "bad argument type - unsupported" x) )

    (define (ensure-typed-atom val)
      (cond ((fixnum? val)      `(,$int ,val))
            ((number? val)      `(,$double ,val))
            ((string? val)      `(,$nonnull-c-string ,val))
            ((char? val)        `(,$char ,val))
            ((boolean? val)     `(,$bool ,val))
            ((null? val)        `(,$scheme-object ,val))
            ((eof-object? val)  `(,$scheme-object ,val))
            (else
             (unknown-type-error val)) ) )

    (define (pair|vector? x)
      (or (pair? x) (vector? x)) )

    (define (ensure-typed-arg arg)
      (cond ((atom? arg) (ensure-typed-atom arg))
            ((list? arg)
             (let ((typ (car arg)))
               (cond ((c $quote typ)
                      (if (not (pair? (cdr arg))) arg
                          (let ((val (cadr arg)))
                            (cond ((symbol? val)      `(,$symbol ',val))
                                  ((u8vector? val)    `(,$nonnull-u8vector ',val))
                                  ((s8vector? val)    `(,$nonnull-s8vector ',val))
                                  ((u16vector? val)   `(,$nonnull-u16vector ',val))
                                  ((s16vector? val)   `(,$nonnull-s16vector ',val))
                                  ((u32vector? val)   `(,$nonnull-u32vector ',val))
                                  ((s32vector? val)   `(,$nonnull-s32vector ',val))
                                  ((f32vector? val)   `(,$nonnull-f32vector ',val))
                                  ((f64vector? val)   `(,$nonnull-f64vector ',val))
                                  ((pair|vector? val) `(,$scheme-object ',val))
                                  (else                (ensure-typed-atom val) ) ) ) ) )
                     ((c $location typ) `(,$nonnull-c-pointer ,arg))
                     ((not (pair? (cdr arg))) (ensure-typed-atom arg))
                     (else (list (r typ) (cadr arg)) ) ) ) )
            (else
             (unknown-type-error arg) ) ) )

    (define (genarg _)
      (let ((sym (r (gensym 'arg))))
        (cons sym (symbol->string sym)) ) )

    ; Note - `rtype' is NOT renamed!
    (let* ((func (cadr form))
           (args (cddr form))
           (rtype (cond ((and (pair? args) (symbol? (car args)))
                         (let ((rtype func))
                           (set! func (car args))
                           (set! args (cdr args))
                           rtype))
                        (else $void)))
           (cargs (map ensure-typed-arg args))
           (fargs (map genarg cargs) ) )
      (cond ((not (null? cargs))
             `((,$foreign-lambda*
                ,rtype
                ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
                ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
                   (conc (if (c $void rtype) body (string-append "return(" body ")")) #\;)))
               ,@(map cadr cargs)) )
            ((c $void rtype)
             `(,$foreign-code ,(conc func #\( #\) #\;) ,rtype))
            (else
             `(,$foreign-value ,(conc func #\( #\)) ,rtype) ) ) ) ) ) )

) ;module dollar