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

(* Last edited Oct. 28th, 1983 by Jim des Rivieres. *)

(* 1.9-LISP primitives. *)

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


(defun primitive? (closure)
   (eq (environment closure) '*primitive*))

(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 prompt&read (stream)
   (printout stream "1> ")
   (import (read stream t)))

(defun prompt&print (result stream)
   (printout stream "1= " .ppv (export result) t))

   
(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 do-primitive (primitive-closure args)
   (prog (result)
      (if (nlsetq
             (setq result (apply* (body primitive-closure) args))
             t) then
           (return result)
       else
           (return 'error.in.primitive))))



(defun prim-number? (a)
   (expect-rail-1 a)
   (make-boolean (numeral? (first a))))

(defun prim-truth-value? (a)
   (expect-rail-1 a)
   (make-boolean (boolean? (first a))))

(defun prim-function? (a)
   (expect-rail-1 a)
   (make-boolean (closure? (first a))))

(defun prim-named-object? (a)
   (expect-rail-1 a)
   (make-boolean (name? (first a))))

(defun prim-sequence? (a)
   (expect-rail-1 a)
   (make-boolean (rail? (first a))))



(defun prim-plus (a)
   (expect-rail-2 a)
   (plus (extract-expected-numeral (first a))
         (extract-expected-numeral (second a))))

(defun prim-times (a)
   (expect-rail-2 a)
   (times (extract-expected-numeral (first a))
         (extract-expected-numeral (second a))))

(defun prim-difference (a)
   (expect-rail-2 a)
   (difference (extract-expected-numeral (first a))
         (extract-expected-numeral (second a))))

(defun prim-quotient (a)
   (expect-rail-2 a)
   (quotient (extract-expected-numeral (first a))
         (extract-expected-numeral (second a))))

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



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

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

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

(defun prim-prep (a)
   (expect-rail-2 a)
   (let ((e (first a))
         (x (expect-rail (second a))))
       (prep e x)))

(defun prim-rcons0 (a)
   (expect-rail-0 a)
   (rcons0))



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


(defun create-global-env ()
  (prog (no-args one-arg two-args)
   (setq global-env ())
   (setq global-env-hash-array (harray 100))

   (setq no-args (rcons0))
   (setq one-arg (prep (make-atom 'x) (rcons0)))
   (setq two-args (prep (make-atom 'x) 
                        (prep (make-atom 'y) (rcons0))))

   (global-rebind 'number?
       (ccons '*primitive* one-arg 'prim-number?
          "True only of numbers."))
   (global-rebind 'function?
       (ccons '*primitive* one-arg 'prim-function?
          "True only of functions."))
   (global-rebind 'sequence?
       (ccons '*primitive* one-arg 'prim-sequence?
          "True only of sequences."))
   (global-rebind 'named-object?
       (ccons '*primitive* one-arg 'prim-named-object?
          "True only of named objects."))
   (global-rebind 'truth-value?
       (ccons '*primitive* one-arg 'prim-truth-value?
          "True only of the truth values $t and $f."))
                       
   (global-rebind '+
       (ccons '*primitive* two-args 'prim-plus
           "Sum of two numbers."))
   (global-rebind '*
       (ccons '*primitive* two-args 'prim-times
           "Product of two numbers."))
   (global-rebind '-
       (ccons '*primitive* two-args 'prim-difference
           "Difference of two numbers."))
   (global-rebind '/
       (ccons '*primitive* two-args 'prim-quotient
           "Quotient of two numbers."))

   (global-rebind 'zero?
       (ccons '*primitive* one-arg 'prim-zero?
           "True only of the number 0."))
   (global-rebind 'less?
       (ccons '*primitive* two-args 'prim-less?
           "The first number is less than the second."))

   (global-rebind '= 
       (ccons '*primitive* two-args 'prim-equal?
         "True only if the two arguments are the same."))

   (global-rebind 'empty?
       (ccons '*primitive* one-arg 'prim-empty?
           "True only of the empty sequence."))
   (global-rebind 'first
       (ccons '*primitive* one-arg 'prim-first
           "The first element of a (non-empty) sequence."))
   (global-rebind 'rest
       (ccons '*primitive* one-arg 'prim-rest
           "The first tail of a (non-empty) sequence."))
   (global-rebind 'prep 
       (ccons '*primitive* two-args 'prim-prep
         "Prepends an element to a sequence."))
   (global-rebind 'empty-sequence 
       (ccons '*primitive* no-args 'prim-rcons0
         "Designates the empty sequence."))


   (setq lambda-closure
       (ccons '*lambda* '*lambda* '*lambda*
          "Function abstractor."))
   (global-rebind 'lambda lambda-closure) 

   (setq if-closure
       (ccons '*if* '*if* '*if*
          "Conditional."))
   (global-rebind 'if if-closure) 

   (setq gset-closure
       (ccons '*gset* '*gset* '*gset*
           "Establish or change global variable binding."))
   (global-rebind 'gset gset-closure) 

   (setq let-closure
       (ccons '*let* '*let* '*let*
           "Introduce temporary variables."))
   (global-rebind 'let let-closure)
))


STOP