;;; This is a -*-Lisp-*- file.
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Stuff to make %primitive and the old style %sp- calls work in the interpreter.
;;;

(defmacro primop (name %sp-name arglist)
  `(progn
    (defun ,%sp-name ,arglist
      (%primitive ,name ,@arglist))
    (setf (get ',name '%primitive-function) ',%sp-name)))

(defmacro %primitive (name &rest args)
  "Invokes the machine instruction named Name with the Args pushed on the stack."
  (let ((fun (get name '%primitive-function)))
    (if fun
	`(,fun ,@args)
	(error "~S is not a known callable instruction." name))))


(primop cons %sp-cons (x y))
(primop alloc-symbol %sp-alloc-symbol (n))
(primop alloc-g-vector %sp-alloc-b-vector (n i))
(primop alloc-i-vector %sp-alloc-u-vector (n a))
(primop alloc-string %sp-alloc-string (n))
(primop alloc-function %sp-alloc-function (n))
(primop alloc-array %sp-alloc-array (n))
(primop get-type %sp-type (x))
(primop make-immediate-type %sp-make-immediate-type (obj type))
(primop get-vector-subtype %sp-get-vector-subtype (v))
(primop set-vector-subtype %sp-set-vector-subtype (v x))
(primop vector-length %sp-get-vector-length (v))
(primop get-value %sp-get-value (s))
(primop set-value %sp-set-value (s h))
(primop get-definition %sp-get-definition (s))
(primop set-definition %sp-set-definition (s d))
(primop get-plist %sp-get-plist (s))
(primop set-plist %sp-set-plist (s p))
(primop get-pname %sp-get-pname (s))
(primop get-package %sp-get-package (s))
(primop set-package %sp-set-package (s p))
(primop boundp %sp-boundp (s))
(primop fboundp %sp-fboundp (s))
(primop negate %sp-negate (n))
(primop lsh %sp-lsh (n b))
(primop get-vector-access-code %sp-get-vector-access-type (v))
(primop logldb %sp-logldb (s p n))
(primop logdpb %sp-logdpb (v s p n))
(primop abs %sp-abs (n))
(primop get-space %sp-subspace (x))
(primop typed-vref %sp-typed-v-access (a v i))
(primop typed-vset %sp-typed-v-store (a v i x))
(primop shrink-vector %sp-shrink-vector (v n))
(primop values-to-n %sp-values-to-n (v))
(primop n-to-values %sp-n-to-values (n))
(primop arg-in-frame %sp-arg-in-frame (n f))
(primop active-call-frame %sp-current-stack-frame ())
(primop set-call-frame %sp-set-stack-frame (p))
(primop current-open-frame %sp-current-open-frame ())
(primop set-open-frame %sp-set-open-frame (p))
(primop current-stack-pointer %sp-current-stack-pointer ())
(primop current-binding-pointer %sp-current-binding-pointer ())
(primop read-control-stack %sp-read-control-stack (f))
(primop write-control-stack %sp-write-control-stack (f v))
(primop read-binding-stack %sp-read-binding-stack (b))
(primop write-binding-stack %sp-write-binding-stack (b v))
(primop ldb %sp-ldb (s p n))
(primop mask-field %sp-mask-field (s p n))
(primop dpb %sp-dpb (v s p n))
(primop deposit-field %sp-deposit-field (v s p n))
(primop ash %sp-ash (n c))
(primop integer-length %sp-haulong (n))
(primop aref1 %sp-v-access (v i))
(primop aref1 %sp-svref (v i))
(primop aset1 %sp-v-store (v i x))
(primop aset1 %sp-svset (v i x))
(primop force-values %sp-force-values ())
(primop flush-values %sp-flush-values ())
(primop newspace-bit %sp-get-newspace-bit ())
(primop halt %sp-halt ())
(primop escape-return %sp-escape-return (x))
(primop break-return %sp-break-return ())
(primop kernel-trap %sp-kernel-trap (u c))
(primop byte-blt %sp-byte-blt (src src-start dst dst-start dst-end))
(primop find-character %sp-find-character (string start end character))
(primop find-character-with-attribute %sp-find-character-with-attribute (a b c d e))
(primop sxhash-simple-string %sp-sxhash-simple-string (string))
(primop sxhash-simple-substring %sp-sxhash-simple-substring (string length))
(primop float-short %sp-short-float (x))
(primop float-short %sp-single-float (x))
(primop float-short %sp-s-float (x))
(primop float-long %sp-long-float (x))
(primop float-long %sp-double-float (x))
(primop float-long %sp-l-float (x))
(primop scale-float %sp-scale-float (x y))
(primop decode-float %sp-decode-float (x))
(primop header-ref %sp-header-ref (x i))
(primop header-set %sp-header-set (x i v))
(primop header-length %sp-header-length (x))
(primop assoc %sp-assoc (x y))
(primop assq %sp-assq (x y))
(primop member %sp-member (x y))
(primop memq %sp-memq (x y))
(primop collect-garbage %sp-collect-garbage ())
(primop long-float-ref %sp-long-float-ref (l i))
(primop long-float-set %sp-long-float-set (l i x))
(primop active-catch-frame %sp-active-catch-frame ())
(primop set-catch-frame %sp-set-catch-frame (x))
(primop io-get-time %sp-io-get-time ())
(primop sap-system-ref %sp-sap-system-ref (s i))
(primop pointer-system-set %sp-pointer-system-ref (s i p))
(primop 8bit-system-ref %sp-8bit-system-ref (s i))
(primop 8bit-system-set %sp-8bit-system-set (s i v))
(primop 16bit-system-ref %sp-16bit-system-ref (s i))
(primop 16bit-system-set %sp-16bit-system-set (s i v))
(primop signed-16bit-system-ref %sp-signed-16bit-system-ref (s i))
(primop signed-32bit-system-ref %sp-signed-32bit-system-ref (s i))
(primop signed-32bit-system-set %sp-signed-32bit-system-set (s i v))
(primop check-<= %sp-check-<= (n l))
(primop getf %sp-getf (l i))
(primop putf %sp-putf (l i v))
(primop get %sp-get (s i))
(primop put %sp-put (s i v))