; -*- Mode: Scheme; Syntax: Scheme; Package: comp;  -*-

; This is file cprim.scm.

;;;; Compiling primitives

(define (definitions-for-all-compiler-primitives) ;yuck
  (map (lambda (name)
	 (let* ((prim (table-ref primitives name))
		(nargs (primitive-nargs prim))
		(some-names (reverse '(a b c d e f g h i j k l)))
		(args (list-tail some-names
				 (- (length some-names) nargs))))
	   ;; Note that if  (primitive-n-ary? prim)  then we are losing!
	   ;; Fix later, somehow.
	   `(define (,name ,@args)
	      (call-primitively ,(primitive-name prim) ,@args))))
       (reverse *primitive-names*)))

(define (make-primitive name nargs n-ary? proc)
  (list name nargs n-ary? proc))
(define primitive-name car)
(define primitive-nargs cadr)
(define primitive-n-ary? caddr)
(define primitive-compilator cadddr)

(define-compilator 'call-primitively
  (lambda (exp cenv cont state)
    (let ((exp (cdr exp)))
      (let ((probe (table-ref primitives (car exp))))
        (if probe
            (compile-primitive-call probe (cdr exp) cenv cont state)
            (begin (warn "procedure in CALL-PRIMITIVELY isn't primitive" exp)
                   (compile-unknown-call exp cenv cont state)))))))

(define (compile-primitive-call primitive args cenv cont state)
  (let ((name (primitive-name primitive)))
    (if ((if (primitive-n-ary? primitive) >= =)
	 (length args) (primitive-nargs primitive))
	((primitive-compilator primitive) args cenv cont state)
        (begin (warn "wrong number of arguments to primitive"
		     (cons name args))
	       (compile-unknown-call (cons (make-system-ref name) args)
				     cenv cont state)))))

(define primitives (make-table))
(define *primitive-names* '())

; "dp" stands for "define-compiler-primitive".
; It wants a short name so that definitions can fit on a single line.

(define (dp name nargs n-ary? proc)
  (table-set! primitives name (make-primitive name nargs n-ary? proc))
  (if (not (memq name *primitive-names*))
      (set! *primitive-names* (cons name *primitive-names*)))
  name)

(dp 'primitive-catch 1 #f  ;(primitive-catch (lambda (cont) ...))
  (lambda (args cenv cont state)
    (maybe-push-continuation (sequentially (emit op/push-cont)
                                           (compile (car args) cenv '(val) state)
                                           (emit op/call 1))
                             cont)))

(dp 'primitive-throw 2 #f  ;(primitive-throw cont val)
  (lambda (args cenv cont state)
    cont ;ignored
    (sequentially (compile (car args) cenv '(val) state)
		  (emit op/push)
		  (compile (cadr args) cenv '(val) state)
		  (emit op/pop-cont)
		  (emit op/return))))

; APPLY wants to first spread the list, then load the procedure.
(dp 'apply 2 #f
  (lambda (args cenv cont state)
    (maybe-push-continuation
     (sequentially (push-all (cdr args) cenv state)
                   (emit op/spread-args (length (cdr args)))
                   (compile (car args) cenv '(val) state) ;procedure arg
                   (emit op/n-call))                  ;pops nargs
     cont)))

; Easy miscellaneous primitives

(define (trivial name)
  (lambda (args cenv cont state)
    (sequentially (if (null? args)
		      empty-segment
		      (push-all-but-last args cenv state))
		  (emit (name->enumerand name op))
		  (dispose-of-val cont))))

; Synchronize this list with ARCH.SCM and PRIM.SCM
; THIS IS RIDICULOUS.  The list should appear in only one place.

(for-each (lambda (z)
	    (dp (car z) (cadr z) #f (trivial (car z))))
	  '(;; Scalar
	    (eq?	       2)
	    (fixnum?           1)
	    (+                 2)
	    (-                 2)
	    (*                 2)
	    (=                 2)
	    (<                 2)
	    (quotient          2)
	    (remainder         2)
	    (char?             1)
	    (char=?            2)
	    (char<?            2)
	    (char->ascii       1)
	    (ascii->char       1)
	    (eof-object?       1)
	    ;; Stored
	    (pair? 1) (cons 2) (car 1) (cdr 1) (set-car! 2) (set-cdr! 2)
	    (symbol? 1) (make-symbol 1) (symbol->string 1)
	    (cell? 1) (make-cell 2) (cell-name 1) (contents 1) (set-contents! 2)
	    (closure? 1) (make-closure 2) (closure-env 1) (closure-template 1)
	    (code-vector? 1) (make-code-vector 2) (code-vector-length 1)
	    (code-vector-ref 2) (code-vector-set! 3)
	    (string? 1) (make-string 2) (string-length 1) (string-ref 2) (string-set! 3)
	    (vector? 1) (make-vector 2) (vector-length 1) (vector-ref 2) (vector-set! 3)
	    ;; I/O
	    (input-port?       1)
	    (output-port?      1)
	    (open-port         2)
	    (close-port	       1)
	    (read-char         1)
	    (peek-char         1)
	    (write-char        2)
	    (write-string      2)
	    ;; Misc
	    (unassigned        0)
	    (halt	       1)
	    (set-enabled-interrupts! 1)
	    (return-from-interrupt 1)
	    (suspend           1)
	    ;; Unnecessary
	    (reverse-list->string 2)
	    (string=?          2)
	    (intern	       2)
	    (lookup	       2)))