(* 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