(* File: {PHYLUM}<DESRIVIERES>NLISP>AARDVARK-PRIMITIVES *)

(* aardvark primitives. *)

(globalvars global-env global-env-hash-array
    lambda-closure if-closure gset-closure
    let-closure)

(defun gset? (closure)
   (eq closure gset-closure))

(defun if? (closure)
   (eq closure if-closure))

(defun lambda? (closure)
   (eq closure lambda-closure))

(defun let? (closure)
   (eq closure let-closure))



(defun expect-rail-0 (x)
   (if (not (rail? x)) then
       (error "1.9-LISP error"))
   (if (not (empty? x)) then
       (error "1.9-LISP error"))
   x)

   
(defun expect-rail-1 (x)
   (if (not (rail? x)) then
       (error "1.9-LISP error"))
   (if (not (equal (rlength x) 1)) then
       (error "1.9-LISP error"))
   x)

(defun expect-rail-2 (x)
   (if (not (rail? x)) then
       (error "1.9-LISP error"))
   (if (not (equal (rlength x) 2)) then
       (error "1.9-LISP error"))
   x)

(defun extract-expected-numeral (x)
   (if (not (numeral? x)) then
       (error "1.9-LISP error")
    else
       (extract-numeral x)))

(defun expect-rail (x)
   (if (not (rail? x)) then
       (error "1.9-LISP error"))
   x)

(defun prim-number? (x)
   (make-boolean (numeral? x)))

(defun prim-truth-value? (x)
   (make-boolean (boolean? x)))

(defun prim-function? (x)
   (make-boolean (closure? x)))

(defun prim-named-object? (x)
   (make-boolean (name? x)))

(defun prim-sequence? (x)
   (make-boolean (rail? x)))



(defun prim-plus (b a)
   (plus (extract-expected-numeral a)
         (extract-expected-numeral b)))

(defun prim-times (b a)
   (times (extract-expected-numeral a)
         (extract-expected-numeral b)))

(defun prim-difference (b a)
   (difference (extract-expected-numeral a)
         (extract-expected-numeral b)))

(defun prim-quotient (b a)
   (quotient (extract-expected-numeral a)
         (extract-expected-numeral b)))

(defun prim-less? (b a)
   (make-boolean
      (lessp (extract-expected-numeral a)
             (extract-expected-numeral b))))
 
(defun prim-zero? (a)
   (make-boolean (zerop (extract-expected-numeral a))))
   
(defun prim-equal? (b a)
   (make-boolean
     (if (and (closure? a) (closure? b)) then
         (error "1.9-LISP error ")
      else
         (equal a b))))



(defun prim-empty? (a)
   (make-boolean (empty? (expect-rail a))))

(defun prim-first (a)
   (if (empty? (expect-rail a)) then
       (error "1.9-lisp error")
    else
       (first a)))

(defun prim-rest (a)
   (if (empty? (expect-rail a)) then
       (error "1.9-lisp error")
    else
       (rest a)))

(defun prim-prep (b a)
   (prep a (expect-rail b)))

(defun prim-rcons0 ()
   (rcons0))



(defun initialise-1.9-lisp-if-necessary ()
   (if (boundp '*rail*) then
       nil
    else
       (initialise-type-tags)
       (initialise-aardvark)
       (create-global-env)
       (build-read-table)
       t))

(defun define-primitive (name nexpected performer comment)
   (prog (pattern code closure reverse-var-list)
      (setq reverse-var-list
        (list (make-atom 'z)
              (make-atom 'y)
              (make-atom 'x)))
      (setq pattern
        (list nexpected 
              (nth reverse-var-list (difference 4 nexpected))))
      (setq code
         (list (list *primitive-opcode* performer))) 
      (setq closure (ccons global-env pattern code))
      (puthash name closure global-env-hash-array)
      (return closure)))


(defun create-global-env ()
  (prog ()
   (setq global-env ())
   (setq global-env-hash-array (harray 100))
   (define-primitive 'number? 1 'prim-number?
          "True only of numbers.")
   (define-primitive 'function? 1 'prim-function?
          "True only of functions.")
   (define-primitive 'sequence? 1 'prim-sequence?
          "True only of sequences.")
   (define-primitive 'named-object? 1 'prim-named-object?
          "True only of named objects.")
   (define-primitive 'truth-value? 1 'prim-truth-value?
          "True only of the truth values $t and $f.")
                       
   (define-primitive '+ 2 'prim-plus
           "Sum of two numbers.")
   (define-primitive '* 2 'prim-times
           "Product of two numbers.")
   (define-primitive '- 2 'prim-difference
           "Difference of two numbers.")
   (define-primitive '/ 2 'prim-quotient
           "Quotient of two numbers.")

   (define-primitive 'zero? 1 'prim-zero?
           "True only of the number 0.")
   (define-primitive 'less? 2 'prim-less?
           "The first number is less than the second.")

   (define-primitive '= 2 'prim-equal?
         "True only if the two arguments are the same.")

   (define-primitive 'empty? 1 'prim-empty?
           "True only of the empty sequence.")
   (define-primitive 'first 1 'prim-first
           "The first element of a (non-empty) sequence.")
   (define-primitive 'rest 1 'prim-rest
           "The first tail of a (non-empty) sequence.")
   (define-primitive 'prep 2 'prim-prep
         "Prepends an element to a sequence.")
   (define-primitive 'empty-sequence 0 'prim-rcons0
         "Designates the empty sequence.")


   (setq lambda-closure
       (ccons '*lambda* '*lambda* '*lambda*
          "Function abstractor."))
   (puthash 'lambda lambda-closure global-env-hash-array) 

   (setq if-closure
       (ccons '*if* '*if* '*if*
          "Conditional."))
   (puthash 'if if-closure global-env-hash-array) 

   (setq gset-closure
       (ccons '*gset* '*gset* '*gset*
           "Establish or change global variable binding."))
   (puthash 'gset gset-closure global-env-hash-array) 

   (setq let-closure
       (ccons '*let* '*let* '*let*
           "Introduce temporary variables."))
   (puthash 'let let-closure global-env-hash-array)
))


STOP