(* File: {PHYLUM}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