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


(globalvars global-env
    lambda-closure if-closure gset-closure
    let-closure sequence-closure)

(defmacro gset? (closure)
   (eq closure gset-closure))

(defmacro if? (closure)
   (eq closure if-closure))

(defmacro lambda? (closure)
   (eq closure lambda-closure))

(defmacro let? (closure)
   (eq closure let-closure))


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

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

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

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

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

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

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



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

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

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

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

(defun prim-less? (a b)
   (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? (a b)
   (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 (a b)
   (prep (if (stack-closure? a) then (wrap a) else a) 
         (expect-rail b)))

(defun prim-empty-sequence () (rcons0))

(defun prim-sequence x
   (for i to x collect (arg x i)))


(defun initialise-1.9-lisp-if-necessary ()
   (if (not (boundp '*RAIL*)) then
       (initialise-1.9-lisp)))

(defun initialise-1.9-lisp ()
   (initialise-type-tags)
   (initialise-opcodes)
   (build-read-table)
   (create-spaces 10 32000 10000)
   (install-scan-stack)
   (create-global-env)
   t)

(defun define-primitive (name nexpected performer comment)
   (prog (closure variables)
      (if (eq nexpected 'no-spread) then 
          (setq closure
             (wrap 
               (ncreate-closure
                  (make-skeleton nil nil 1
                     (list (make-atom 'args))
                     (list (list *primitive-opcode* performer))
                     (concat name ": " comment)
                     (pcons (make-atom name) (make-atom 'args)))
                  global-env)))
       else
          (selectq nexpected 
             (0 (setq variables  nil))
             (1 (setq variables (list (make-atom 'x))))
             (2 (setq variables (list (make-atom 'x) 
                                      (make-atom 'y))))
             (3 (setq variables (list (make-atom 'x) 
                                      (make-atom 'y) 
                                      (make-atom 'z))))
             (shouldnt "Primitives can have at most 3 arguments"))
          (setq closure
             (wrap 
               (ncreate-closure
                  (make-skeleton nil t nexpected variables                     
                     (list (list *primitive-opcode* performer))
                     (concat name ": " comment)
                     (pcons (make-atom name)
                        (list-to-rail variables)))
                  global-env))) )

      (put name 'nlisp closure)
      (return closure)))

(defun define-reflective-primitive (name comment)
   (prog (closure)
      (setq closure
          (wrap (ncreate-closure
                    (make-skeleton t nil nil nil nil 
                    (concat name ": " comment)
                    nil)
                    global-env)))
      (put name 'nlisp closure)
      (return closure)))


(defmacro nlisp-global-binding (v)
   (prog (plist)
     (setq plist (getproplist v))
   loop
     (if (neq (car plist) 'nlisp) then
         (if (listp (setq plist (cddr plist))) then 
             (go loop))
         (return 'not.found)
      else
         (return (cadr plist)))))



(defun create-global-env ()
  (prog ()
   (setq global-env ())
   (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-empty-sequence
         "Designates the empty sequence.")
   (setq sequence-closure
      (define-primitive 'sequence 'no-spread 'prim-sequence
         "Designates the sequence of given elements."))

   (setq lambda-closure
      (define-reflective-primitive 'lambda 
          "Function abstractor."))

   (setq if-closure
      (define-reflective-primitive 'if 
          "Conditional."))

   (setq gset-closure
       (define-reflective-primitive 'gset
           "Establish or change global variable binding."))

   (setq let-closure
       (define-reflective-primitive 'let
           "Introduce temporary variables."))

))


STOP