;;;; primitives.scm
;
; Copyright (c) 2007, 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

(import-for-syntax matchable chicken)

(define-for-syntax (crunch:cify-name name)
  (string-intersperse
   (map (lambda (c)
	  (if (or (char-alphabetic? c)
		  (char-numeric? c) )
	      (string c)
	      (sprintf 
	       "_~a"
	       (string-pad (number->string (char->integer c) 16) 2 #\0))))
	(string->list (->string name)))
   ""))

(define-syntax (defprimitives x r c)
  (let ((prims (cdr x)))
    `(,(r 'begin)
      ,@(map
	 (match-lambda
	   (((name args ...) (and ra (or '-> '+>)) result . rm)
	    (let ((real-name (optional rm (conc "crunch_" (crunch:cify-name name)))))
	      `(,(r 'crunch-register-primitive)
		',name ',args ',result
		,real-name #f ,(eq? ra '+>)) ) )
	   (def (syntax-error 
		 'defprimitives
		 "invalid primitive definition" def)) )
	 prims) ) ) )


;;; R5RS

(defprimitives
  ((+ number number) -> number*)
  ((- number number) -> number*)
  ((* number number) -> number*)
  ((/ number number) -> number*)
  ((= number number) -> bool)
  ((< number number) -> bool)
  ((> number number) -> bool)
  ((<= number number) -> bool)
  ((>= number number) -> bool)
  ((quotient int int) -> int)
  ((remainder int int) -> int)
  ((modulo int int) -> int)
  ((max number number) -> number*)
  ((min number number) -> number*)
  ((abs number) -> number*)
  ((floor number) -> number*)
  ((ceiling number) -> number*)
  ((truncate number) -> number*)
  ((round number) -> number*)
  ((eq? * *) -> bool)
  ((eqv? * *) -> bool)
  ((equal? * *) -> bool)
  ((not *) -> bool)
  ((newline) -> void)
  ((display *) -> void)
  ((write-char char) -> void)
  ((integer? *) -> bool)
  ((positive? number) -> bool)
  ((negative? number) -> bool)
  ((odd? int) -> bool)
  ((even? int) -> bool)
  ((exact? number) -> bool)
  ((inexact? number) -> bool)
  ((sqrt double) -> double)
  ((sin double) -> double)
  ((cos double) -> double)
  ((tan double) -> double)
  ((exp double) -> double)
  ((log double) -> double)
  ((expt double double) -> double)
  ((asin double) -> double)
  ((acos double) -> double)
  ((atan double) -> double)
  ((atan2 double double) -> double)
  ((exact->inexact number) -> double)
  ((inexact->exact number) -> int)
  ((zero? number) -> bool) 
  ((make-string int char) -> string)
  ((string-ref string int) -> char)
  ((string-set! string int char) -> void)
  ((string-length string) -> int)
  ((substring string int int) -> string)
  ((string-append string string) -> string)
  ((string-copy string) -> string)
  ((string-fill! string char) -> void)
  ((string=? string string) -> bool)
  ((string>? string string) -> bool)
  ((string<? string string) -> bool)
  ((string>=? string string) -> bool)
  ((string<=? string string) -> bool)
  ((string-ci=? string string) -> bool)
  ((string-ci>? string string) -> bool)
  ((string-ci<? string string) -> bool)
  ((string-ci>=? string string) -> bool)
  ((string-ci<=? string string) -> bool)
  ((number->string number int) -> string)
  ((string->number string int) +> number)
  ((char-upper-case? char) -> bool)
  ((char-lower-case? char) -> bool)
  ((char-alphabetic? char) -> bool)
  ((char-numeric? char) -> bool)
  ((char-whitespace? char) -> bool)
  ((char-upcase char) -> char)
  ((char-downcase char) -> char)
  ((char->integer char) -> int)
  ((integer->char int) -> char)
  ((char=? char char) -> bool)
  ((char>? char char) -> bool)
  ((char<? char char) -> bool)
  ((char>=? char char) -> bool)
  ((char<=? char char) -> bool)
  ((char-ci=? char char) -> bool)
  ((char-ci>? char char) -> bool)
  ((char-ci<? char char) -> bool)
  ((char-ci>=? char char) -> bool)
  ((char-ci<=? char char) -> bool) )


;;; Extensions

(defprimitives
  ((void) -> void)
  ((##sys#void) -> void)
  ((u8vector-ref u8vector int) -> int)
  ((u8vector-set! u8vector int int) -> void)
  ((u16vector-ref u16vector int) -> int)
  ((u16vector-set! u16vector int int) -> void)
  ((u32vector-ref u32vector int) -> int)
  ((u32vector-set! u32vector int int) -> void)
  ((s8vector-ref s8vector int) -> int)
  ((s8vector-set! s8vector int int) -> void)
  ((s16vector-ref s16vector int) -> int)
  ((s16vector-set! s16vector int int) -> void)
  ((s32vector-ref s32vector int) -> int)
  ((s32vector-set! s32vector int int) -> void)
  ((f32vector-ref f32vector int) -> float)
  ((f32vector-set! f32vector int float) -> void)
  ((f64vector-ref f64vector int) -> double)
  ((f64vector-set! f64vector int double) -> void)
  ((make-u8vector int int) -> u8vector)
  ((make-s8vector int int) -> s8vector)
  ((make-u16vector int int) -> u16vector)
  ((make-s16vector int int) -> s16vector)
  ((make-u32vector int int) -> u32vector)
  ((make-s32vector int int) -> s32vector)
  ((make-f32vector int double) -> f32vector)
  ((make-f64vector int double) -> f64vector)
  ((u8vector-length u8vector) -> int)
  ((s8vector-length s8vector) -> int)
  ((u16vector-length u16vector) -> int)
  ((s16vector-length s16vector) -> int)
  ((u32vector-length u32vector) -> int)
  ((s32vector-length s32vector) -> int)
  ((f32vector-length f32vector) -> int)
  ((f64vector-length f64vector) -> int)
  ((blob->string blob) -> string)
  ((string->blob string) -> blob)
  ((blob->string/shared blob) -> string)
  ((string->blob/shared blob) -> blob)
  ((blob->u8vector blob) -> u8vector)
  ((blob->s8vector blob) -> s8vector)
  ((blob->u16vector blob) -> u16vector)
  ((blob->s16vector blob) -> s16vector)
  ((blob->u32vector blob) -> u32vector)
  ((blob->s32vector blob) -> s32vector)
  ((blob->f32vector blob) -> f32vector)
  ((blob->f64vector blob) -> f64vector)
  ((blob->u8vector/shared blob) -> u8vector)
  ((blob->s8vector/shared blob) -> s8vector)
  ((blob->u16vector/shared blob) -> u16vector)
  ((blob->s16vector/shared blob) -> s16vector)
  ((blob->u32vector/shared blob) -> u32vector)
  ((blob->s32vector/shared blob) -> s32vector)
  ((blob->f32vector/shared blob) -> f32vector)
  ((blob->f64vector/shared blob) -> f64vector)
  ((u8vector->blob blob) -> blob)
  ((s8vector->blob blob) -> blob)
  ((u16vector->blob blob) -> blob)
  ((s16vector->blob blob) -> blob)
  ((u32vector->blob blob) -> blob)
  ((s32vector->blob blob) -> blob)
  ((f32vector->blob blob) -> blob)
  ((f64vector->blob blob) -> blob)
  ((u8vector->blob/shared blob) -> blob)
  ((s8vector->blob/shared blob) -> blob)
  ((u16vector->blob/shared blob) -> blob)
  ((s16vector->blob/shared blob) -> blob)
  ((u32vector->blob/shared blob) -> blob)
  ((s32vector->blob/shared blob) -> blob)
  ((f32vector->blob/shared blob) -> blob)
  ((f64vector->blob/shared blob) -> blob)
  ((subu8vector u8vector int int) -> u8vector)
  ((subs8vector s8vector int int) -> s8vector)
  ((subu16vector u16vector int int) -> u16vector)
  ((subs16vector s16vector int int) -> s16vector)
  ((subu32vector u32vector int int) -> u32vector)
  ((subs32vector s32vector int int) -> s32vector)
  ((subf32vector f32vector int int) -> f32vector)
  ((subf64vector f64vector int int) -> f64vector)
  ((flush-output) -> void)
  ((bitwise-and int int) -> int)
  ((bitwise-ior int int) -> int)
  ((bitwise-xor int int) -> int)
  ((bitwise-not int) -> int)
  ((arithmetic-shift int int) -> int)
  ((error string) -> void)
  ((exit int) -> void)
  ((argc) -> int)
  ((argv-ref int) -> string)
  ((sub1 number) -> number*)
  ((add1 number) -> number*) )

(defprimitives
  ((pointer-u8-ref c-pointer int) -> int)
  ((pointer-s8-ref c-pointer int) -> int)
  ((pointer-u16-ref c-pointer int) -> int)
  ((pointer-s16-ref c-pointer int) -> int)
  ((pointer-u32-ref c-pointer int) -> int)
  ((pointer-s32-ref c-pointer int) -> int)
  ((pointer-f32-ref c-pointer int) -> float)
  ((pointer-f64-ref c-pointer int) -> double)
  ((pointer-u8-set! c-pointer int int) -> void)
  ((pointer-s8-set! c-pointer int int) -> void)
  ((pointer-u16-set! c-pointer int int) -> void)
  ((pointer-s16-set! c-pointer int int) -> void)
  ((pointer-u32-set! c-pointer int int) -> void)
  ((pointer-s32-set! c-pointer int int) -> void)
  ((pointer-f32-set! c-pointer float int) -> void)
  ((pointer-f64-set! c-pointer double int) -> void) )