;; -*-theme-d-*-

;; Copyright (C) 2008-2018 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library core)

  (prevent-stripping <condition>)

  (prevent-stripping <eof>)
  
  (add-method equal? equal-values?)

  (define make-eof
    (prim-proc eof-object () <eof> nonpure))
  
  (define raise
    (unchecked-prim-proc raise (<object>) <none> (pure never-returns)))

  (define exit
    (unchecked-prim-proc theme-exit (<integer>) <none>
			 (nonpure never-returns)))

  (define raw-exit
    (unchecked-prim-proc exit (<integer>) <none>
			 (nonpure never-returns)))

  (define call/cc
    (param-prim-proc
     theme-call/cc
     (%normal %jump)
     ((:simple-proc ((:simple-proc (%jump) <none> (pure never-returns)))
		    %normal pure))
     (:union %normal %jump) pure))

  (define call/cc-nonpure
    (param-prim-proc
    theme-call/cc
     (%normal %jump)
     ((:simple-proc ((:simple-proc (%jump) <none> (pure never-returns)))
		    %normal nonpure))
     (:union %normal %jump) nonpure))

  (define call/cc-without-result
    (prim-proc
     theme-call/cc-without-result
     ((:simple-proc ((:simple-proc () <none> (pure never-returns)))
		   <none> nonpure))
     <none> nonpure))

 (define with-exception-handler
    (param-prim-proc theme-with-exception-handler
                     (%result)
                     ((:procedure (<object>) <none> (pure never-returns))
                      (:procedure () %result pure))
                     %result
                     pure))

 (define with-exception-handler-nonpure
    (param-prim-proc theme-with-exception-handler
                     (%result)
                     ((:procedure (<object>) <none> (nonpure never-returns))
                      (:procedure () %result nonpure))
                     %result
                     nonpure))

  (define _debug-print
    (unchecked-prim-proc theme-debug-print (<object>) <none> nonpure))
  
  (define command-line-arguments
    (prim-proc theme-command-line () (:uniform-list <string>) pure))

  (define set-verbose-errors!
    (unchecked-prim-proc set-verbose-errors! (<boolean>) <none> nonpure))
  
  (define set-backtrace!
    (unchecked-prim-proc set-backtrace! (<boolean>) <none> nonpure))

  (define set-pretty-backtrace!
    (unchecked-prim-proc set-pretty-backtrace! (<boolean>) <none> nonpure))

  (define enable-rte-exception-info
    (unchecked-prim-proc theme-enable-rte-exception-info () <none> pure))
  
  (define disable-rte-exception-info
    (unchecked-prim-proc theme-disable-rte-exception-info () <none> pure))

  (define null?
    (unchecked-prim-proc null? (<object>) <boolean> (pure always-returns)))

  (define eof?
    (unchecked-prim-proc eof-object?
			 (<object>) <boolean> (pure always-returns)))

  (define symbol?
    (unchecked-prim-proc symbol? (<object>) <boolean> (pure always-returns)))

  (define integer?
    (unchecked-prim-proc is-integer? (<object>) <boolean>
			 (pure always-returns)))

  (define real?
    (unchecked-prim-proc is-real? (<object>) <boolean> (pure always-returns)))

  (define character?
    (unchecked-prim-proc char? (<object>) <boolean> (pure always-returns)))

  (define string?
    (unchecked-prim-proc string? (<object>) <boolean> (pure always-returns)))

  (define boolean?
    (unchecked-prim-proc boolean? (<object>) <boolean> (pure always-returns)))

  (define symbol=?
    (unchecked-prim-proc eq? (<symbol> <symbol>) <boolean> pure))

  (define integer=?
    (unchecked-prim-proc eqv? (<integer> <integer>) <boolean> pure))

  (define real=?
    (unchecked-prim-proc eqv? (<real> <real>) <boolean> pure))

  (define character=?
    (unchecked-prim-proc eqv? (<character> <character>) <boolean> pure))

  (define string=?
    (unchecked-prim-proc string=? (<string> <string>) <boolean> pure))

  (define boolean=?
    (unchecked-prim-proc eq? (<boolean> <boolean>) <boolean> pure))

  (define integer=
    (unchecked-prim-proc = (<integer> <integer>) <boolean> pure))

  (define real=
    (unchecked-prim-proc = (<real> <real>) <boolean> pure))

  (define integer-real=
    (unchecked-prim-proc = (<integer> <real>) <boolean> pure))

  (define real-integer=
    (unchecked-prim-proc = (<real> <integer>) <boolean> pure))

  (add-method equal? boolean=?)
  (add-method equal? symbol=?)
  (add-method equal? integer=?)
  (add-method equal? real=?)
  (add-method equal? character=?)
  (add-method equal? string=?)

  (define-simple-method equal? (((x1 <null>) (x2 <null>)) <boolean> pure)
    #t)

  (add-static-method equal?
		     (unchecked-prim-proc eq? (<boolean> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eq? (<object> <boolean>) <boolean>
					  pure))

  (add-static-method equal?
		     (unchecked-prim-proc eq? (<symbol> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eq? (<object> <symbol>) <boolean>
					  pure))

  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<integer> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<object> <integer>) <boolean>
					  pure))
  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<real> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<object> <real>) <boolean>
					  pure))

  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<character> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eqv? (<object> <character>) <boolean>
					  pure))

  (add-static-method equal?
		     (unchecked-prim-proc equal? (<string> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc equal? (<object> <string>) <boolean>
					  pure))

  (add-static-method equal?
		     (unchecked-prim-proc eq? (<null> <object>) <boolean>
					  pure))
  
  (add-static-method equal?
		     (unchecked-prim-proc eq? (<object> <null>) <boolean>
					  pure))

  (add-method = integer=)
  (add-method = real=)
  (add-method = integer-real=)
  (add-method = real-integer=)

  (define pair?
    (unchecked-prim-proc pair? (<object>) <boolean> (pure always-returns)))

  (define-param-proc-alt car (%type1 %type2)
    (unchecked-prim-proc car ((:pair %type1 %type2)) %type1
			 (pure always-returns)))

  (define-param-proc-alt cdr (%type1 %type2)
    (unchecked-prim-proc cdr ((:pair %type1 %type2)) %type2
			 (pure always-returns)))

  (define not-null?
    (unchecked-prim-proc not-null? (<object>) <boolean> (pure always-returns))) 

  (define not
    (unchecked-prim-proc not (<boolean>) <boolean> (pure always-returns)))

  (define-simple-proc not-object (((x <object>)) <boolean> pure)
    (if (equal? x #f) #t #f))

  (define xor
    (unchecked-prim-proc xor (<boolean> <boolean>) <boolean>
			 (pure always-returns)))

  (define-param-proc-alt vector-ref (%type)
    (unchecked-prim-proc _i_vector-ref
			 ((:vector %type) <integer>) %type pure))

  (define-param-proc-alt mutable-vector-ref (%type)
    (unchecked-prim-proc _i_mutable-vector-ref
			 ((:mutable-vector %type) <integer>)
			 %type pure))

  (define-param-proc-alt mutable-vector-set! (%type)
    (unchecked-prim-proc _i_mutable-vector-set!
			 ((:mutable-vector %type)
			  <integer> %type) <none> nonpure))


  (define-param-proc-alt value-vector-ref (%type)
    (unchecked-prim-proc _i_value-vector-ref
			 ((:value-vector %type) <integer>) %type pure))
  

  (define-param-proc-alt mutable-value-vector-ref (%type)
    (unchecked-prim-proc _i_mutable-value-vector-ref
			 ((:mutable-value-vector %type) <integer>)
			 %type pure))


  (define-param-proc-alt mutable-value-vector-set! (%type)
    (unchecked-prim-proc _i_mutable-value-vector-set!
			 ((:mutable-value-vector %type)
			  <integer> %type) <none> nonpure))


  (define-param-proc-alt vector-length (%type)
    (unchecked-prim-proc _b_vector-length ((:vector %type))
			 <integer> (pure always-returns)))


  (define-param-proc-alt mutable-vector-length (%type)
    (unchecked-prim-proc _b_vector-length ((:mutable-vector %type))
			 <integer> (pure always-returns)))


  (define-param-proc-alt value-vector-length (%type)
    (unchecked-prim-proc _b_vector-length ((:value-vector %type))
			 <integer> (pure always-returns)))


  (define-param-proc-alt mutable-value-vector-length (%type)
    (unchecked-prim-proc _b_vector-length ((:mutable-value-vector %type))
			 <integer> (pure always-returns)))


  (define-param-proc-alt cons (%type1 %type2)
    (unchecked-prim-proc cons
			 (%type1 %type2)
			 (:pair %type1 %type2)
			 (pure always-returns)))

  (define-param-proc gen-car (%type1 %type2)
		     (((pair (:union (:pair %type1 %type2) <null>)))
		      %type1
		      (pure))
    (if (null? pair)
	(raise-simple 'gen-car:null)
	(car (cast (:pair %type1 %type2) pair))))

  (define-param-proc gen-cdr (%type1 %type2)
		     (((pair (:union (:pair %type1 %type2) <null>)))
		      %type2
		      (pure))
    (if (null? pair)
	(raise-simple 'gen-cdr:null)
	(cdr (cast (:pair %type1 %type2) pair))))

  (define make-rte-exception
    (prim-proc make-theme-d-condition
	       (<rte-exception-kind> <rte-exception-info>)
	       <condition> pure))

  (define rte-exception?
    (prim-proc theme-d-condition? (<object>) <boolean> pure))

  (define get-rte-exception-kind0
    (prim-proc theme-d-condition-kind (<condition>)
	       (:alt-maybe <rte-exception-kind>) pure))
  
  (define get-rte-exception-info0
    (prim-proc theme-d-condition-info (<condition>)
	       (:alt-maybe <rte-exception-info>) pure))

  (define get-rte-exception-kind
    (prim-proc theme-d-condition-kind1 (<condition>) <rte-exception-kind> pure))
  
  (define get-rte-exception-info
    (prim-proc theme-d-condition-info1 (<condition>)
	       (:alt-maybe <rte-exception-info>) pure))

  (define-simple-proc make-simple-exception (((s-kind <symbol>))
					     <condition> pure)
    (make-rte-exception s-kind null))

  (define-simple-proc raise-simple (((s-kind <symbol>))
				    <none> (pure never-returns))
    (raise (make-simple-exception s-kind)))

  (define-simple-proc make-numerical-overflow (((s-proc-name <symbol>))
					       <condition> pure)
    (make-rte-exception 'numerical-overflow
			(list (cons 's-proc-name s-proc-name))))

  (define-simple-proc raise-numerical-overflow (((s-proc-name <symbol>))
						<none> (pure never-returns))
    (raise (make-numerical-overflow s-proc-name)))

  (define-param-proc-alt list (%arglist)
    (unchecked-prim-proc list ((splice %arglist)) %arglist pure))

  (define-param-proc member?
      (%type)
      (((obj %type)
	(lst (:uniform-list %type)))
       <boolean> pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal? obj (car lst1))
	   #t
	   (member? obj (cdr lst1))))))

  ;; The result types of primitive numerical procedures are checked because
  ;; of the way numerical types are implemented in Scheme.

  (define integer+
    (prim-proc + (<integer> <integer>) <integer> pure))

  (define real+
    (prim-proc + (<real> <real>) <real> pure))

  (define integer-real+
    (prim-proc + (<integer> <real>) <real> pure))

  (define real-integer+
    (prim-proc + (<real> <integer>) <real> pure))

  (add-method + integer+)

  (add-method + real+)

  (add-method + integer-real+)

  (add-method + real-integer+)


  (define integer-
    (prim-proc - (<integer> <integer>) <integer> pure))

  (define real-
    (prim-proc - (<real> <real>) <real> pure))

  (define integer-real-
    (prim-proc - (<integer> <real>) <real> pure))

  (define real-integer-
    (prim-proc - (<real> <integer>) <real> pure))

  (add-method - integer-)

  (add-method - real-)

  (add-method - integer-real-)

  (add-method - real-integer-)


  (define integer*
    (prim-proc * (<integer> <integer>) <integer> pure))

  (define real*
    (prim-proc * (<real> <real>) <real> pure))

  (define integer-real*
    (prim-proc * (<integer> <real>) <real> pure))

  (define real-integer*
    (prim-proc * (<real> <integer>) <real> pure))

  (add-method * integer*)

  (add-method * real*)

  (add-method * integer-real*)

  (add-method * real-integer*)


  (define real/
    (prim-proc / (<real> <real>) <real> pure))

  (define integer-real/
    (prim-proc / (<integer> <real>) <real> (pure)))

  (define real-integer/
    (prim-proc theme-real-integer/ (<real> <integer>) <real> (pure)))

  (add-method / real/)

  (add-method / integer-real/)

  (add-method / real-integer/)


  (define i-neg
    (prim-proc - (<integer>) <integer> (pure)))

  (define r-neg
    (prim-proc - (<real>) <real> (pure)))

  (add-method - i-neg)

  (add-method - r-neg)


  (define integer<
    (unchecked-prim-proc < (<integer> <integer>) <boolean> pure))

  (define real<
    (unchecked-prim-proc < (<real> <real>) <boolean> pure))

  (define integer-real<
    (unchecked-prim-proc < (<integer> <real>) <boolean> pure))

  (define real-integer<
    (unchecked-prim-proc < (<real> <integer>) <boolean> pure))

  (add-method < integer<)

  (add-method < real<)

  (add-method < integer-real<)

  (add-method < real-integer<)


  (define integer<=
    (unchecked-prim-proc <= (<integer> <integer>) <boolean> pure))

  (define real<=
    (unchecked-prim-proc <= (<real> <real>) <boolean> pure))

  (define integer-real<=
    (unchecked-prim-proc <= (<integer> <real>) <boolean> pure))

  (define real-integer<=
    (unchecked-prim-proc <= (<real> <integer>) <boolean> pure))

  (add-method <= integer<=)

  (add-method <= real<=)

  (add-method <= integer-real<=)

  (add-method <= real-integer<=)


  (define integer>
    (unchecked-prim-proc > (<integer> <integer>) <boolean> pure))

  (define real>
    (unchecked-prim-proc > (<real> <real>) <boolean> pure))

  (add-method > integer>)

  (add-method > real>)

  (define integer-real>
    (unchecked-prim-proc > (<integer> <real>) <boolean> pure))

  (define real-integer>
    (unchecked-prim-proc > (<real> <integer>) <boolean> pure))

  (add-method > integer-real>)

  (add-method > real-integer>)


  (define integer>=
    (unchecked-prim-proc >= (<integer> <integer>) <boolean> pure))

  (define real>=
    (unchecked-prim-proc >= (<real> <real>) <boolean> pure))

  (define integer-real>=
    (unchecked-prim-proc >= (<integer> <real>) <boolean> pure))

  (define real-integer>=
    (unchecked-prim-proc >= (<real> <integer>) <boolean> pure))

  (add-method >= integer>=)

  (add-method >= real>=)

  (add-method >= integer-real>=)

  (add-method >= real-integer>=))
