bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
Xlisp source Part 1 of 6 shar format. Read the file read.me after unpacking all the files. Enjoy! #!/bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #!/bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # art.lsp # example.lsp # fact.lsp # fib.lsp # hanoi.lsp # hdwr.lsp # ifthen.lsp # init.lsp # prolog.lsp # queens.lsp # queens2.lsp # This archive created: Sat Jan 18 14:32:15 1986 # By: Jwahar R. Bammi () export PATH; PATH=/bin:$PATH echo shar: extracting "'art.lsp'" '(2341 characters)' if test -f 'art.lsp' then echo shar: over-writing existing file "'art.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'art.lsp' X; This is an example using the object-oriented programming support in X; XLISP. The example involves defining a class of objects representing X; dictionaries. Each instance of this class will be a dictionary in X; which names and values can be stored. There will also be a facility X; for finding the values associated with names after they have been X; stored. X X; Create the 'Dictionary' class and establish its instance variable list. X; The variable 'entries' will point to an association list representing the X; entries in the dictionary instance. X X(setq Dictionary (Class :new '(entries))) X X; Setup the method for the ':isnew' initialization message. X; This message will be send whenever a new instance of the 'Dictionary' X; class is created. Its purpose is to allow the new instance to be X; initialized before any other messages are sent to it. It sets the value X; of 'entries' to nil to indicate that the dictionary is empty. X X(Dictionary :answer :isnew '() X '((setq entries nil) X self)) X X; Define the message ':add' to make a new entry in the dictionary. This X; message takes two arguments. The argument 'name' specifies the name X; of the new entry; the argument 'value' specifies the value to be X; associated with that name. X X(Dictionary :answer :add '(name value) X '((setq entries X (cons (cons name value) entries)) X value)) X X; Create an instance of the 'Dictionary' class. This instance is an empty X; dictionary to which words may be added. X X(setq d (Dictionary :new)) X X; Add some entries to the new dictionary. X X(d :add 'mozart 'composer) X(d :add 'winston 'computer-scientist) X X; Define a message to find entries in a dictionary. This message takes X; one argument 'name' which specifies the name of the entry for which to X; search. It returns the value associated with the entry if one is X; present in the dictionary. Otherwise, it returns nil. X X(Dictionary :answer :find '(name &aux entry) X '((cond ((setq entry (assoc name entries)) X (cdr entry)) X (t X nil)))) X X; Try to find some entries in the dictionary we created. X X(d :find 'mozart) X(d :find 'winston) X(d :find 'bozo) X X; The names 'mozart' and 'winston' are found in the dictionary so their X; values 'composer' and 'computer-scientist' are returned. The name 'bozo' X; is not found so nil is returned in this case. SHAR_EOF if test 2341 -ne "`wc -c 'art.lsp'`" then echo shar: error transmitting "'art.lsp'" '(should have been 2341 characters)' fi echo shar: extracting "'example.lsp'" '(2464 characters)' if test -f 'example.lsp' then echo shar: over-writing existing file "'example.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'example.lsp' X; Make the class ship and its instance variables be known X X(setq ship (Class :new '(x y xv yv m name captain registry))) X X X(ship :answer :getx '() '( x )) ; just evaluate x X(ship :answer :getxv '() '( xv )) ; note that the method is a X(ship :answer :gety '() '( y )) ; list of forms, the value X(ship :answer :getyv '() '( yv )) ; of the last one being the X(ship :answer :getm '() '( m )) ; value of the method X(ship :answer :getname '() '( name )) X(ship :answer :getcaptain '() '( captain )) X(ship :answer :getregistry '() '( registry )) X X; formal X; param X; of X; method X(ship :answer :setx '(to) '( (setq x to) ) ) X(ship :answer :setxv '(to) '( (setq xv to) ) ) X(ship :answer :sety '(to) '( (setq y to) ) ) X(ship :answer :setyv '(to) '( (setq yv to) ) ) X(ship :answer :setm '(to) '( (setq m to) ) ) X(ship :answer :setname '(to) '( (setq name to) ) ) X(ship :answer :setcaptain '(to) '( (setq captain to) ) ) X(ship :answer :setregistry '(to) '( (setq registry to) ) ) X X(ship :answer :sail '(time) X ; the METHOD for sailing X '( (princ (list "sailing for " time " hours\n")) X ; note that this form is expressed in terms of objects: "self" X ; is bound to the object being talked to during the execution X ; of its message. It can ask itself to do things. X (self :setx (+ (self :getx) X (* (self :getxv) time))) X ; This form performs a parallel action to the above, but more X ; efficiently, and in this instance, more clearly X (setq y (+ y (* yv time))) X ; Cute message for return value. Tee Hee. X "Sailing, sailing, over the bountiful chow mein...")) X X; <OBJECT: #12345667> is not terribly instructive. How about a more X; informative print routine? X X(ship :answer :print '() '((princ (list X "SHIP NAME: " (self :getname) "\n" X "REGISTRY: " (self :getregistry) "\n" X "CAPTAIN IS: " (self :getcaptain) "\n" X "MASS IS: " (self :getm) " TONNES\n" X "CURRENT POSITION IS: " X (self :getx) " X BY " X (self :gety) " Y\n" X "SPEED IS: " X (self :getxv) " XV BY " X (self :getyv) " YV\n") ) )) X X; a function to make life easier X X(defun newship (mass name registry captain &aux new) X (setq new (ship :new)) X (new :setx 0) X (new :sety 0) X (new :setxv 0) X (new :setyv 0) X (new :setm mass) X (new :setname name) X (new :setcaptain captain) X (new :setregistry registry) X (new :print) X new) X X; and an example object. X X(setq Bounty (newship 50 'Bounty 'England 'Bligh)) SHAR_EOF if test 2464 -ne "`wc -c 'example.lsp'`" then echo shar: error transmitting "'example.lsp'" '(should have been 2464 characters)' fi echo shar: extracting "'fact.lsp'" '(96 characters)' if test -f 'fact.lsp' then echo shar: over-writing existing file "'fact.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'fact.lsp' X; good old factorial X X(defun fact (n) X (cond ((= n 1) 1) X (t (* n (fact (- n 1)))))) SHAR_EOF if test 96 -ne "`wc -c 'fact.lsp'`" then echo shar: error transmitting "'fact.lsp'" '(should have been 96 characters)' fi echo shar: extracting "'fib.lsp'" '(90 characters)' if test -f 'fib.lsp' then echo shar: over-writing existing file "'fib.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'fib.lsp' X(defun fib (x) X (cond ((< x 2) 1) X (t (+ (fib (1- x)) (fib (- x 2)))))) SHAR_EOF if test 90 -ne "`wc -c 'fib.lsp'`" then echo shar: error transmitting "'fib.lsp'" '(should have been 90 characters)' fi echo shar: extracting "'hanoi.lsp'" '(448 characters)' if test -f 'hanoi.lsp' then echo shar: over-writing existing file "'hanoi.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'hanoi.lsp' X; Good ol towers of hanoi X; X; Usage: X; (hanoi <n>) X; <n> - an integer the number of discs X X(defun hanoi(n) X ( transfer 'A 'B 'C n )) X X(defun print-move ( from to ) X (princ "Move Disk From ") X (princ from) X (princ " To ") X (princ to) X (princ "\n")) X X X(defun transfer ( from to via n ) X (cond ((equal n 1) (print-move from to )) X (t (transfer from via to (- n 1)) X (print-move from to) X (transfer via to from (- n 1))))) X X SHAR_EOF if test 448 -ne "`wc -c 'hanoi.lsp'`" then echo shar: error transmitting "'hanoi.lsp'" '(should have been 448 characters)' fi echo shar: extracting "'hdwr.lsp'" '(8603 characters)' if test -f 'hdwr.lsp' then echo shar: over-writing existing file "'hdwr.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'hdwr.lsp' X; -*-Lisp-*- X; X; Jwahar R. Bammi X; A simple description of hardware objects using xlisp X; Mix and match instances of the objects to create your X; organization. X; Needs: X; - busses and connection and the Design X; Class that will have the connections as instance vars. X; - Print method for each object, that will display X; the instance variables in an human readable form. X; Some day I will complete it. X; X; X; X; utility functions X X X; function to calculate 2^n X X(defun pow2 (n) X (pow2x n 1)) X X(defun pow2x (n sum) X (cond((equal n 0) sum) X (t (pow2x (- n 1) (* sum 2))))) X X X; hardware objects X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;The class areg X X(setq areg (Class :new '(value nbits max_val min_val))) X X; methods X X; initialization method X; when a new instance is called for the user supplies X; the parameter nbits, from which the max_val & min_val are derived X X(areg :answer :isnew '(n) X '((self :init n) X self)) X X(areg :answer :init '(n) X '((setq value ()) X (setq nbits n) X (setq max_val (- (pow2 (- n 1)) 1)) X (setq min_val (- (- 0 max_val) 1)))) X X; load areg X X(areg :answer :load '(val) X '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n"))) X ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n"))) X (t (setq value val))))) X X; see areg X X(areg :answer :see '() X '((cond ((null value) (princ "Register does not contain a value\n")) X (t value)))) X; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X; The class creg ( a register that can be cleared and incremented) X; subclass of a reg X X(setq creg (Class :new '() '() areg)) X X; it inherites all the instance vars & methods of a reg X; in addition to them it has the following methods X X(creg :answer :isnew '(n) X '((self :init n) X self)) X X(creg :answer :init '(n) X '((setq value ()) X (setq nbits n) X (setq max_val (- (pow2 n) 1)) X (setq min_val 0))) X X(creg :answer :clr '() X '((setq value 0))) X X(creg :answer :inc '() X '((cond ((null value) (princ "Register does not contain a value\n")) X (t (setq value (rem (+ value 1) (+ max_val 1))))))) X X; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; X; Register bank X; contains n areg's n_bits each X X(setq reg_bank (Class :new '(regs n_regs curr_reg))) X X;methods X X(reg_bank :answer :isnew '(n n_bits) X '((self :init n n_bits) X self)) X X(reg_bank :answer :init '(n n_bits) X '((setq regs ()) X (setq n_regs (- n 1)) X (self :initx n n_bits))) X X(reg_bank :answer :initx '(n n_bits) X '((cond ((equal n 0) t) X (t (list (setq regs (cons (areg :new n_bits) regs)) X (self :initx (setq n (- n 1)) n_bits)))))) X X(reg_bank :answer :load '(reg val) X '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n"))) X (t (setq curr_reg (nth (+ reg 1) regs)) X (curr_reg :load val))))) X X(reg_bank :answer :see '(reg) X '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n"))) X (t (setq curr_reg (nth (+ reg 1) regs)) X (curr_reg :see))))) X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; The Class alu X X;alu - an n bit alu X X(setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf))) X X; methods X X(alu :answer :isnew '(n) X '((self :init n) X self)) X X(alu :answer :init '(n) X '((setq n_bits n) X (setq maxu_val (- (pow2 n) 1)) X (setq maxs_val (- (pow2 (- n 1)) 1)) X (setq mins_val (- (- 0 maxs_val) 1)) X (setq minu_val 0) X (setq nf 0) X (setq zf 0) X (setq vf 0) X (setq cf 0))) X X(alu :answer :check_arith '(a b) X '((cond ((and (self :arith_range a) (self :arith_range b)) t) X (t ())))) X X(alu :answer :check_logic '(a b) X '((cond ((and (self :logic_range a) (self :logic_range b)) t) X (t ())))) X X(alu :answer :arith_range '(a) X '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n"))) X ((> a maxs_val) (princ (list "Operand out of range "a"\n"))) X (t t)))) X X(alu :answer :logic_range '(a) X '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n"))) X (t t)))) X X(alu :answer :set_flags '(a b r) X '((if (equal 0 r) ((setq zf 1))) X (if (< r 0) ((setq nf 1))) X (if (or (and (and (< a 0) (< 0 b)) (>= r 0)) X (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1))) X (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0))) X (and (>= r 0) (< b 0))) ((setq cf 1))))) X X(alu :answer :+ '(a b &aux result) X '((cond ((null (self :check_arith a b)) ()) X (t (self :clear_flags) X (setq result (+ a b)) X (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val)))) X (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1))))) X (self :set_flags a b result) X result)))) X X(alu :answer :& '(a b &aux result) X '((cond ((null (self :check_logic a b)) ()) X (t (self :clear_flags) X (setq result (bit-and a b)) X (self :set_flags a b result) X result)))) X X(alu :answer :| '(a b &aux result) X '((cond ((null (self :check_logic a b)) ()) X (t (self :clear_flags) X (setq result (bit-ior a b)) X (self :set_flags a b result) X result)))) X X(alu :answer :~ '(a &aux result) X '((cond ((null (self :check_logic a 0)) ()) X (t (self :clear_flags) X (setq result (bit-not a)) X (self :set_flags a 0 result) X result)))) X X(alu :answer :- '(a b) X '((self '+ a (- 0 b)))) X X(alu :answer :passa '(a) X '(a)) X X(alu :answer :zero '() X '(0)) X X(alu :answer :com '(a) X '((self :- 0 a))) X X(alu :answer :status '() X '((princ (list "NF "nf"\n")) X (princ (list "ZF "zf"\n")) X (princ (list "CF "cf"\n")) X (princ (list "VF "vf"\n")))) X X(alu :answer :clear_flags '() X '((setq nf 0) X (setq zf 0) X (setq cf 0) X (setq vf 0))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; X; The class Memory X; X X(setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry))) X X; methods X X(memory :answer :isnew '(addr_bits data_bits) X '((self :init addr_bits data_bits) X self)) X X(memory :answer :init '(addr_bits data_bits) X '((setq nabits addr_bits) X (setq ndbits data_bits) X (setq maxu_val (- (pow2 data_bits) 1)) X (setq max_addr (- (pow2 addr_bits) 1)) X (setq maxs_val (- (pow2 (- data_bits 1)) 1)) X (setq mins_val (- 0 (pow2 (- data_bits 1)))) X (setq undef (+ maxu_val 1)) X (setq memry (array :new max_addr undef)))) X X X(memory :answer :load '(loc val) X '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n"))) X ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n"))) X ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n"))) X (t (memry :load loc val))))) X X(memory :answer :write '(loc val) X '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n"))) X ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n"))) X ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n"))) X (t (memry :load loc val))))) X X X(memory :answer :read '(loc &aux val) X '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n"))) X (t (setq val (memry :see loc)) X (cond ((equal undef val) (princ (list "Address "loc" read before write\n"))) X (t val)))))) X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; X; The class array X X(setq array (Class :new '(arry))) X X; methods X X(array :answer :isnew '(n val) X '((self :init n val) X self)) X X(array :answer :init '(n val) X '((cond ((< n 0) t) X (t (setq arry (cons val arry)) X (self :init (- n 1) val))))) X X(array :answer :see '(n) X '((nth (+ n 1) arry))) X X X(array :answer :load '(n val &aux left right temp) X '((setq left (self :left_part n arry temp)) X (setq right (self :right_part n arry)) X (setq arry (append left (list val))) X (setq arry (append arry right)) X val)) X X(array :answer :left_part '(n ary left) X '((cond ((equal n 0) (reverse left)) X (t (setq left (cons (car ary) left)) X (self :left_part (- n 1) (cdr ary) left))))) X X(array :answer :right_part '(n ary &aux right) X '((cond ((equal n 0) (cdr ary)) X (t (self :right_part (- n 1) (cdr ary)))))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SHAR_EOF if test 8603 -ne "`wc -c 'hdwr.lsp'`" then echo shar: error transmitting "'hdwr.lsp'" '(should have been 8603 characters)' fi echo shar: extracting "'ifthen.lsp'" '(6843 characters)' if test -f 'ifthen.lsp' then echo shar: over-writing existing file "'ifthen.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'ifthen.lsp' X; -*-Lisp-*- X; X; If then rules - mini expert from Ch. 18 of Winston and Horn X; Written using recursion without progs X; Added function 'how' to explain deductions X; X; Use: X; After loading type (deduce). It will make all the deductions X; given the list fact. If you want to know how it deduced something X; type (how '(a deduction)) for example (how '(animal is tiger)) X; and so on. X X X X; rules data base X X(setq rules X '((rule identify1 X (if (animal has hair)) X (then (animal is mammal))) X (rule identify2 X (if (animal gives milk)) X (then (animal is mammal))) X (rule identify3 X (if (animal has feathers)) X (then (animal is bird))) X (rule identify4 X (if (animal flies) X (animal lays eggs)) X (then (animal is bird))) X (rule identify5 X (if (animal eats meat)) X (then (animal is carnivore))) X (rule identify6 X (if (animal has pointed teeth) X (animal has claws) X (animal has forward eyes)) X (then (animal is carnivore))) X (rule identify7 X (if (animal is mammal) X (animal has hoofs)) X (then (animal is ungulate))) X (rule identify8 X (if (animal is mammal) X (animal chews cud)) X (then (animal is ungulate) X (even toed))) X (rule identify9 X (if (animal is mammal) X (animal is carnivore) X (animal has tawny color) X (animal has dark spots)) X (then (animal is cheetah))) X (rule identify10 X (if (animal is mammal) X (animal is carnivore) X (animal has tawny color) X (animal has black stripes)) X (then (animal is tiger))) X (rule identify11 X (if (animal is ungulate) X (animal has long neck) X (animal has long legs) X (animal has dark spots)) X (then (animal is giraffe))) X (rule identify12 X (if (animal is ungulate) X (animal has black stripes)) X (then (animal is zebra))) X (rule identify13 X (if (animal is bird) X (animal does not fly) X (animal has long neck) X (animal has long legs) X (animal is black and white)) X (then (animal is ostrich))) X (rule identify14 X (if (animal is bird) X (animal does not fly) X (animal swims) X (animal is black and white)) X (then (animal is penguin))) X (rule identify15 X (if (animal is bird) X (animal flys well)) X (then (animal is albatross))))) X; utility functions X(defun squash(s) X (cond ((null s) ()) X ((atom s) (list s)) X (t (append (squash (car s)) X (squash (cdr s)))))) X X(defun p(s) X (princ (squash s))) X X; functions X X; function to see if an item is a member of a list X X(defun member(item list) X (cond((null list) ()) ; return nil on end of list X ((equal item (car list)) list) ; found X (t (member item (cdr list))))) ; otherwise try rest of list X X; put a new fact into the facts data base if it is not already there X X(defun remember(newfact) X (cond((member newfact facts) ()) ; if present do nothing X (t ( setq facts (cons newfact facts)) newfact))) X X; is a fact there in the facts data base X X(defun recall(afact) X (cond ((member afact facts) afact) ; it is here X (t ()))) ; no it is'nt X X; given a rule check if all the if parts are confirmed by the facts data base X X(defun testif(iflist) X (cond((null iflist) t) ; all satisfied X ((recall (car iflist)) (testif (cdr iflist))) ; keep searching X ; if one is ok X (t ()))) ; not in facts DB X X; add the then parts of the rules which can be added to the facts DB X; return the ones that are added X X(defun usethen(thenlist addlist) X (cond ((null thenlist) addlist) ; all exhausted X ((remember (car thenlist)) X (usethen (cdr thenlist) (cons (car thenlist) addlist))) X (t (usethen (cdr thenlist) addlist)))) X X; try a rule X; return t only if all the if parts are satisfied by the facts data base X; and at lest one then ( conclusion ) is added to the facts data base X X(defun tryrule(rule &aux ifrules thenlist addlist) X (setq ifrules (cdr(car(cdr(cdr rule))))) X (setq thenlist (cdr(car(cdr(cdr(cdr rule)))))) X (setq addlist '()) X (cond (( testif ifrules) X (cond ((setq addlist (usethen thenlist addlist)) X (p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n")) X (setq ruleused (cons rule ruleused)) X t) X (t ()))) X (t ()))) X X; step through one iteration if the forward search X; looking for rules that can be deduced from the present fact data base X X(defun stepforward( rulelist) X (cond((null rulelist) ()) ; all done X ((tryrule (car rulelist)) t) X ( t (stepforward(cdr rulelist))))) X X; stepforward until you cannot go any further X X(defun deduce() X (cond((stepforward rules) (deduce)) X (t t))) X X; function to answer if a fact was used to come to a certain conclusion X; uses the ruleused list cons'ed by tryrule to answer X X(defun usedp(rule) X (cond ((member rule ruleused) t) ; it has been used X (t () ))) ; no it hasnt X X; function to answer how a fact was deduced X X(defun how(fact) X (how2 fact ruleused nil)) X X(defun how2(fact rulist found) X (cond ((null rulist) ; if the rule list exhausted X (cond (found t) ; already answered the question return t X ((recall fact) (p (list fact " was a given fact\n")) t) ;known fact X (t (p (list fact " -- not a fact!\n")) ()))) X X ((member fact (thenpart (car rulist))) ; if rulist not empty X (setq found t) ; and fact belongs to the then part of a rule X (p (list fact " was deduced because the following were true\n")) X (printifs (car rulist)) X (how2 fact (cdr rulist) found)) X (t (how2 fact (cdr rulist) found)))) X X; function to return the then part of a rule X X(defun thenpart(rule) X (cdr(car(cdr(cdr(cdr rule)))))) X X; function to print the if part of a given rule X X(defun printifs(rule) X (pifs (cdr(car(cdr(cdr rule)))))) X X(defun pifs(l) X (cond ((null l) ()) X (t (p (list "\t" (car l) "\n")) X (pifs (cdr l))))) X X X; initial facts data base X; Uncomment one or make up your own X; Then run 'deduce' to find deductions X; Run 'how' to find out how it came to a certain deduction X X;(setq facts X; '((animal has dark spots) X; (animal has tawny color) X; (animal eats meat) X; (animal has hair))) X X(setq facts X '((animal has hair) X (animal has pointed teeth) X (animal has black stripes) X (animal has claws) X (animal has forward eyes) X (animal has tawny color))) X X X(setq rl1 X '(rule identify14 X (if (animal is bird) X (animal does not fly) X (animal swims) X (animal is black and white)) X (then (animal is penguin)))) X X(setq rl2 X '(rule identify10 X (if (animal is mammal) X (animal is carnivore) X (animal has tawny color) X (animal has black stripes)) X (then (animal is tiger)))) X X; Initialization X(expand 10) X(setq ruleused nil) SHAR_EOF if test 6843 -ne "`wc -c 'ifthen.lsp'`" then echo shar: error transmitting "'ifthen.lsp'" '(should have been 6843 characters)' fi echo shar: extracting "'init.lsp'" '(1963 characters)' if test -f 'init.lsp' then echo shar: over-writing existing file "'init.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'init.lsp' X; get some more memory X(expand 1) X X; some fake definitions for Common Lisp pseudo compatiblity X(setq first car) X(setq second cadr) X(setq rest cdr) X X; some more cxr functions X(defun caddr (x) (car (cddr x))) X(defun cadddr (x) (cadr (cddr x))) X X; (when test code...) - execute code when test is true X(defmacro when (test &rest code) X `(cond (,test ,@code))) X X; (unless test code...) - execute code unless test is true X(defmacro unless (test &rest code) X `(cond ((not ,test) ,@code))) X X; (makunbound sym) - make a symbol be unbound X(defun makunbound (sym) (setq sym '*unbound*) sym) X X; (objectp expr) - object predicate X(defun objectp (x) (eq (type-of x) :OBJECT)) X X; (filep expr) - file predicate X(defun filep (x) (eq (type-of x) :FILE)) X X; (unintern sym) - remove a symbol from the oblist X(defun unintern (sym) (cond ((member sym *oblist*) X (setq *oblist* (delete sym *oblist*)) X t) X (t nil))) X X; (mapcan ...) X(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args))) X X; (mapcon ...) X(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args))) X X; (save fun) - save a function definition to a file X(defmacro save (fun) X `(let* ((fname (strcat (symbol-name ',fun) ".lsp")) X (fval ',fun) X (fp (openo fname))) X (cond (fp (print (cons (if (eq (car fval) 'lambda) X 'defun X 'defmacro) X (cons fun (cdr fval))) fp) X (close fp) X fname) X (t nil)))) X X; (debug) - enable debug breaks X(defun debug () X (setq *breakenable* t)) X X; (nodebug) - disable debug breaks X(defun nodebug () X (setq *breakenable* nil)) X X; initialize to enable breaks but no trace back X(setq *breakenable* t) X(setq *tracenable* nil) SHAR_EOF if test 1963 -ne "`wc -c 'init.lsp'`" then echo shar: error transmitting "'init.lsp'" '(should have been 1963 characters)' fi echo shar: extracting "'prolog.lsp'" '(4302 characters)' if test -f 'prolog.lsp' then echo shar: over-writing existing file "'prolog.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'prolog.lsp' X;; The following is a tiny Prolog interpreter in MacLisp X;; written by Ken Kahn and modified for XLISP by David Betz. X;; It was inspired by other tiny Lisp-based Prologs of X;; Par Emanuelson and Martin Nilsson. X;; There are no side-effects anywhere in the implementation. X;; Though it is VERY slow of course. X X(defun prolog (database &aux goal) X (do () ((not (progn (princ "Query?") (setq goal (read))))) X (prove (list (rename-variables goal '(0))) X '((bottom-of-environment)) X database X 1))) X X;; prove - proves the conjunction of the list-of-goals X;; in the current environment X X(defun prove (list-of-goals environment database level) X (cond ((null list-of-goals) ;; succeeded since there are no goals X (print-bindings environment environment) X (not (y-or-n-p "More?"))) X (t (try-each database database X (cdr list-of-goals) (car list-of-goals) X environment level)))) X X(defun try-each (database-left database goals-left goal environment level X &aux assertion new-enviroment) X (cond ((null database-left) nil) ;; fail since nothing left in database X (t (setq assertion X (rename-variables (car database-left) X (list level))) X (setq new-environment X (unify goal (car assertion) environment)) X (cond ((null new-environment) ;; failed to unify X (try-each (cdr database-left) database X goals-left goal X environment level)) X ((prove (append (cdr assertion) goals-left) X new-environment X database X (+ 1 level))) X (t (try-each (cdr database-left) database X goals-left goal X environment level)))))) X X(defun unify (x y environment &aux new-environment) X (setq x (value x environment)) X (setq y (value y environment)) X (cond ((variable-p x) (cons (list x y) environment)) X ((variable-p y) (cons (list y x) environment)) X ((or (atom x) (atom y)) X (cond ((equal x y) environment) X (t nil))) X (t (setq new-environment (unify (car x) (car y) environment)) X (cond (new-environment (unify (cdr x) (cdr y) new-environment)) X (t nil))))) X X(defun value (x environment &aux binding) X (cond ((variable-p x) X (setq binding (assoc x environment :test #'equal)) X (cond ((null binding) x) X (t (value (cadr binding) environment)))) X (t x))) X X(defun variable-p (x) X (and x (listp x) (eq (car x) '?))) X X(defun rename-variables (term list-of-level) X (cond ((variable-p term) (append term list-of-level)) X ((atom term) term) X (t (cons (rename-variables (car term) list-of-level) X (rename-variables (cdr term) list-of-level))))) X X(defun print-bindings (environment-left environment) X (cond ((cdr environment-left) X (cond ((= 0 (nth 2 (caar environment-left))) X (prin1 (cadr (caar environment-left))) X (princ " = ") X (print (value (caar environment-left) environment)))) X (print-bindings (cdr environment-left) environment)))) X X;; a sample database: X(setq db '(((father madelyn ernest)) X ((mother madelyn virginia)) X ((father david arnold)) X ((mother david pauline)) X ((father rachel david)) X ((mother rachel madelyn)) X ((grandparent (? grandparent) (? grandchild)) X (parent (? grandparent) (? parent)) X (parent (? parent) (? grandchild))) X ((parent (? parent) (? child)) X (mother (? parent) (? child))) X ((parent (? parent) (? child)) X (father (? parent) (? child))))) X X;; the following are utilities X(defun y-or-n-p (prompt) X (princ prompt) X (eq (read) 'y)) X X;; start things going X(prolog db) SHAR_EOF if test 4302 -ne "`wc -c 'prolog.lsp'`" then echo shar: error transmitting "'prolog.lsp'" '(should have been 4302 characters)' fi echo shar: extracting "'queens.lsp'" '(1408 characters)' if test -f 'queens.lsp' then echo shar: over-writing existing file "'queens.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'queens.lsp' X; X; Place n queens on a board X; See Winston and Horn Ch. 11 X; X; Usage: X; (queens <n>) X; where <n> is an integer -- the size of the board - try (queens 4) X X(defun cadar (x) X (car (cdr (car x)))) X X; Do two queens threaten each other ? X(defun threat (i j a b) X (or (equal i a) ;Same row X (equal j b) ;Same column X (equal (- i j) (- a b)) ;One diag. X (equal (+ i j) (+ a b)))) ;the other diagonal X X; Is poistion (n,m) on the board safe for a queen ? X(defun conflict (n m board) X (cond ((null board) nil) X ((threat n m (caar board) (cadar board)) t) X (t (conflict n m (cdr board))))) X X X; Place queens on a board of size SIZE X(defun queens (size) X (prog (n m board) X (setq board nil) X (setq n 1) ;Try the first row X loop-n X (setq m 1) ;Column 1 X loop-m X (cond ((conflict n m board) (go un-do-m))) ;Check for conflict X (setq board (cons (list n m) board)) ; Add queen to board X (cond ((> (setq n (1+ n)) size) ; Placed N queens ? X (print (reverse board)))) ; Print config X (go loop-n) ; Next row which column? X un-do-n X (cond ((null board) (return 'Done)) ; Tried all possibilities X (t (setq m (cadar board)) ; No, Undo last queen placed X (setq n (caar board)) X (setq board (cdr board)))) X X un-do-m X (cond ((> (setq m (1+ m)) size) ; Go try next column X (go un-do-n)) X (t (go loop-m))))) SHAR_EOF if test 1408 -ne "`wc -c 'queens.lsp'`" then echo shar: error transmitting "'queens.lsp'" '(should have been 1408 characters)' fi echo shar: extracting "'queens2.lsp'" '(2326 characters)' if test -f 'queens2.lsp' then echo shar: over-writing existing file "'queens2.lsp'" fi sed 's/^X//' << \SHAR_EOF > 'queens2.lsp' X; X; Place n queens on a board (graphical version) X; See Winston and Horn Ch. 11 X; X; Usage: X; (queens <n>) X; where <n> is an integer -- the size of the board - try (queens 4) X X(defun cadar (x) X (car (cdr (car x)))) X X; Do two queens threaten each other ? X(defun threat (i j a b) X (or (equal i a) ;Same row X (equal j b) ;Same column X (equal (- i j) (- a b)) ;One diag. X (equal (+ i j) (+ a b)))) ;the other diagonal X X; Is poistion (n,m) on the board safe for a queen ? X(defun conflict (n m board) X (cond ((null board) nil) X ((threat n m (caar board) (cadar board)) t) X (t (conflict n m (cdr board))))) X X X; Place queens on a board of size SIZE X(defun queens (size) X (prog (n m board soln) X (setq soln 0) ;Solution # X (setq board nil) X (setq n 1) ;Try the first row X loop-n X (setq m 1) ;Column 1 X loop-m X (cond ((conflict n m board) (go un-do-m))) ;Check for conflict X (setq board (cons (list n m) board)) ; Add queen to board X (cond ((> (setq n (1+ n)) size) ; Placed N queens ? X (print-board (reverse board) (setq soln (1+ soln))))) ; Print it X (go loop-n) ; Next row which column? X un-do-n X (cond ((null board) (return 'Done)) ; Tried all possibilities X (t (setq m (cadar board)) ; No, Undo last queen placed X (setq n (caar board)) X (setq board (cdr board)))) X X un-do-m X (cond ((> (setq m (1+ m)) size) ; Go try next column X (go un-do-n)) X (t (go loop-m))))) X X X;Print a board X(defun print-board (board soln &aux size) X (setq size (length board)) ;we can find our own size X (terpri) X (princ "\t\tSolution: ") X (print soln) X (terpri) X (princ "\t") X (print-header size 1) X (terpri) X (print-board-aux board size 1) X (terpri)) X X; Put Column #'s on top X(defun print-header (size n) X (cond ((> n size) terpri) X (t (princ n) X (princ " ") X (print-header size (1+ n))))) X X(defun print-board-aux (board size row) X (terpri) X (cond ((null board)) X (t (princ row) ;print the row # X (princ "\t") X (print-board-row (cadar board) size 1) ;Print the row X (print-board-aux (cdr board) size (1+ row))))) ;Next row X X(defun print-board-row (column size n) X (cond ((> n size)) X (t (cond ((equal column n) (princ "Q")) X (t (princ "."))) X (princ " ") X (print-board-row column size (1+ n))))) SHAR_EOF if test 2326 -ne "`wc -c 'queens2.lsp'`" then echo shar: error transmitting "'queens2.lsp'" '(should have been 2326 characters)' fi # End of shell archive exit 0 -- Jwahar R. Bammi Usenet: .....!decvax!cwruecmp!bammi CSnet: bammi@case Arpa: bammi%case@csnet-relay CompuServe: 71515,155
bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlisp.doc
# read.me
# This archive created: Sat Jan 18 14:32:17 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlisp.doc'" '(53933 characters)'
if test -f 'xlisp.doc'
then
echo shar: over-writing existing file "'xlisp.doc'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.doc'
X
X
X
X
X
X XLISP: An Experimental Object Oriented Language
X
X Version 1.5
X
X May 27, 1985
X
X
X by
X David Michael Betz
X 114 Davenport Ave.
X Manchester, NH 03103
X
X (603) 625-4691 (home)
X
X Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use
X
X
X XLISP: An Experimental Object Oriented Language Page 2
X TABLE OF CONTENTS
X
X
X CONTENTS
X
X 1 INTRODUCTION . . . . . . . . . . . . . . . . . . . . 3
X 2 A NOTE FROM THE AUTHOR . . . . . . . . . . . . . . . 4
X 3 XLISP COMMAND LOOP . . . . . . . . . . . . . . . . 5
X 4 BREAK COMMAND LOOP . . . . . . . . . . . . . . . . 6
X 5 DATA TYPES . . . . . . . . . . . . . . . . . . . . . 7
X 6 THE EVALUATOR . . . . . . . . . . . . . . . . . . . 8
X 7 LEXICAL CONVENTIONS . . . . . . . . . . . . . . . . 9
X 8 OBJECTS . . . . . . . . . . . . . . . . . . . . . 10
X 8.1 THE 'Object' CLASS . . . . . . . . . . . . . . . 11
X 8.2 THE 'Class' CLASS . . . . . . . . . . . . . . . 12
X 9 SYMBOLS . . . . . . . . . . . . . . . . . . . . . 13
X 10 FUNCTION DEFINITIONS . . . . . . . . . . . . . . . 14
X 10.1 EVALUATION FUNCTIONS . . . . . . . . . . . . . . 14
X 10.2 SYMBOL FUNCTIONS . . . . . . . . . . . . . . . . 15
X 10.3 PROPERTY LIST FUNCTIONS . . . . . . . . . . . . 17
X 10.4 LIST FUNCTIONS . . . . . . . . . . . . . . . . . 18
X 10.5 DESTRUCTIVE LIST FUNCTIONS . . . . . . . . . . . 21
X 10.6 PREDICATE FUNCTIONS . . . . . . . . . . . . . . 22
X 10.7 CONTROL FUNCTIONS . . . . . . . . . . . . . . . 24
X 10.8 LOOPING FUNCTIONS . . . . . . . . . . . . . . . 25
X 10.9 THE PROGRAM FEATURE . . . . . . . . . . . . . . 26
X 10.10 DEBUGGING AND ERROR HANDLING . . . . . . . . . . 27
X 10.11 ARITHMETIC FUNCTIONS . . . . . . . . . . . . . . 28
X 10.12 BITWISE LOGICAL FUNCTIONS . . . . . . . . . . . 30
X 10.13 RELATIONAL FUNCTIONS . . . . . . . . . . . . . . 31
X 10.14 STRING FUNCTIONS . . . . . . . . . . . . . . . . 32
X 10.15 INPUT/OUTPUT FUNCTIONS . . . . . . . . . . . . . 33
X 10.16 FILE I/O FUNCTIONS . . . . . . . . . . . . . . . 34
X 10.17 SYSTEM FUNCTIONS . . . . . . . . . . . . . . . . 35
X
X
X XLISP: An Experimental Object Oriented Language Page 3
X INTRODUCTION
X
X
X 1 INTRODUCTION
X
X XLISP is an experimental programming language combining some of the
X features of LISP with an object oriented extension capability. It was
X implemented to allow experimentation with object oriented programming
X on small computers. There are currently implementations running on
X the the VAX under VAX/VMS and Berkeley VAX/UNIX, on the 8088/8086
X under CP/M-86 and MS-DOS, on the 68000 under CP/M-68K and on the
X Macintosh. It is completely written in the programming language 'C'
X and is easily extended with user written built-in functions and
X classes. It is available in source form free of charge to
X non-commercial users.
X
X Many traditional LISP functions are built into XLISP. In addition,
X XLISP defines the objects 'Object' and 'Class' as primitives.
X 'Object' is the only class that has no superclass and hence is the
X root of the class heirarchy tree. 'Class' is the class of which all
X classes are instances (it is the only object that is an instance of
X itself).
X
X This document is a brief description of XLISP. It assumes some
X knowledge of LISP and some understanding of the concepts of
X object-oriented programming.
X
X A recommended text for learning LISP programming is the book "LISP" by
X Winston and Horn and published by Addison Wesley. The first edition
X of this book is based on MacLisp and the second edition is based on
X Common Lisp. Future versions of XLISP will continue to migrate
X towards compatibility with Common Lisp.
X
X
X XLISP: An Experimental Object Oriented Language Page 4
X A NOTE FROM THE AUTHOR
X
X
X 2 A NOTE FROM THE AUTHOR
X
X If you have any problems with XLISP, feel free to contact me for help
X or advice. Please remember that since XLISP is available in source
X form in a high level language, many users have been making versions
X available on a variety of machines. If you call to report a problem
X with a specific version, I may not be able to help you if that version
X runs on a machine to which I don't have access. Please have the
X version number of the version that you are running readily accessible
X before calling me.
X
X If you find a bug in XLISP, first try to fix the bug yourself using
X the source code provided. If you are successful in fixing the bug,
X send the bug report along with the fix to me. If you don't have
X access to a C compiler or are unable to fix a bug, please send the bug
X report to me and I'll try to fix it.
X
X Any suggestions for improvements will be welcomed. Feel free to
X extend the language in whatever way suits your needs. However, PLEASE
X DO NOT RELEASE ENHANCED VERSIONS WITHOUT CHECKING WITH ME FIRST!! I
X would like to be the clearing house for new features added to XLISP.
X If you want to add features for your own personal use, go ahead. But,
X if you want to distribute your enhanced version, contact me first.
X Please remember that the goal of XLISP is to provide a language to
X learn and experiment with LISP and object-oriented programming on
X small computers. I don't want it to get so big that it requires
X megabytes of memory to run.
X
X
X XLISP: An Experimental Object Oriented Language Page 5
X XLISP COMMAND LOOP
X
X
X 3 XLISP COMMAND LOOP
X
X When XLISP is started, it first tries to load "init.lsp" from the
X default directory. It then loads any files named as parameters on the
X command line (after appending ".lsp" to their names). It then issues
X the following prompt:
X
X >
X
X This indicates that XLISP is waiting for an expression to be typed.
X When an incomplete expression has been typed (one where the left and
X right parens don't match) XLISP changes its prompt to:
X
X n>
X
X where n is an integer indicating how many levels of left parens remain
X unclosed.
X
X When a complete expression has been entered, XLISP attempts to
X evaluate that expression. If the expression evaluates successfully,
X XLISP prints the result of the evaluation and then returns to the
X initial prompt waiting for another expression to be typed.
X
X Input can be aborted at any time by typing the CONTROL-G key (it may
X be necessary to follow CONTROL-G by RETURN).
X
X
X XLISP: An Experimental Object Oriented Language Page 6
X BREAK COMMAND LOOP
X
X
X 4 BREAK COMMAND LOOP
X
X When XLISP encounters an error while evaluating an expression, it
X attempts to handle the error in the following way:
X
X If the symbol '*breakenable*' is true, the message corresponding to
X the error is printed. If the error is correctable, the correction
X message is printed. If the symbol '*tracenable*' is true, a trace
X back is printed. The number of entries printed depends on the value
X of the symbol '*tracelimit*'. If this symbol is set to something
X other than a number, the entire trace back stack is printed. XLISP
X then enters a read/eval/print loop to allow the user to examine the
X state of the interpreter in the context of the error. This loop
X differs from the normal top-leval read/eval/print loop in that if the
X user invokes the function 'continue' XLISP will continue from a
X correctable error. If the user invokes the function 'quit' XLISP will
X abort the break loop and return to the top level or the next lower
X numbered break loop. When in a break loop, XLISP prefixes the break
X level to the normal prompt.
X
X If the symbol '*breakenable*' is nil, XLISP looks for a surrounding
X errset function. If one is found, XLISP examines the value of the
X print flag. If this flag is true, the error message is printed. In
X any case, XLISP causes the errset function call to return nil.
X
X If there is no surrounding errset function, XLISP prints the error
X message and returns to the top level.
X
X
X XLISP: An Experimental Object Oriented Language Page 7
X DATA TYPES
X
X
X 5 DATA TYPES
X
X There are several different data types available to XLISP programmers.
X
X
X o lists
X
X o symbols
X
X o strings
X
X o integers
X
X o floats
X
X o objects
X
X o file pointers
X
X o subrs (built-in functions)
X
X o fsubrs (special forms)
X
X Another data type is the stream. A stream is a list node whose car
X points to the head of a list of integers and whose cdr points to the
X last list node of the list. An empty stream is a list node whose car
X and cdr are nil. Each of the integers in the list represents a
X character in the stream. When a character is read from a stream, the
X first integer from the head of the list is removed and returned. When
X a character is written to a stream, the integer representing the
X character code of the character is appended to the end of the list.
X When a function indicates that it takes an input source as a
X parameter, this parameter can either be an input file pointer or a
X stream. Similarly, when a function indicates that it takes an output
X sink as a parameter, this parameter can either be an output file
X pointer or a stream.
X
X
X XLISP: An Experimental Object Oriented Language Page 8
X THE EVALUATOR
X
X
X 6 THE EVALUATOR
X
X The process of evaluation in XLISP:
X
X o Integers, floats, strings, file pointers, subrs, fsubrs and
X objects evaluate to themselves
X
X o Symbols evaluate to the value associated with their current
X binding
X
X o Lists are evaluated by evaluating the first element of the
X list and then taking one of the following actions:
X
X o If it is a subr, the remaining list elements are
X evaluated and the subr is called with these evaluated
X expressions as arguments.
X
X o If it is an fsubr, the fsubr is called using the
X remaining list elements as arguments (unevaluated)
X
X o If it is a list:
X
X 1. If the list is a function closure (a list whose car
X is a lambda expression and whose cdr is an
X environment list), the car of the list is used as the
X function to be applied and the cdr is used as the
X environment to be extended with the parameter
X bindings.
X
X 2. If the list is a lambda expression, the current
X environment is used for the function application.
X
X 3. In either of the above two cases, the remaining list
X elements are evaluated and the resulting expressions
X are bound to the formal arguments of the lambda
X expression. The body of the function is executed
X within this new binding environment.
X
X
X o If it is a list and the car of the list is 'macro', the
X remaining list elements are bound to the formal arguments
X of the macro expression. The body of the function is
X executed within this new binding environment. The result
X of this evaluation is considered the macro expansion.
X This result is then evaluated in place of the original
X expression.
X
X o If it is an object, the second list element is evaluated
X and used as a message selector. The message formed by
X combining the selector with the values of the remaining
X list elements is sent to the object.
X
X
X
X
X XLISP: An Experimental Object Oriented Language Page 9
X LEXICAL CONVENTIONS
X
X
X 7 LEXICAL CONVENTIONS
X
X The following conventions are followed when entering XLISP programs:
X
X Comments in XLISP code begin with a semi-colon character and continue
X to the end of the line.
X
X Symbol names in XLISP can consist of any sequence of non-blank
X printable characters except the following:
X
X ( ) ' ` , " ;
X
X Uppercase and lowercase characters are not distinguished within symbol
X names. All lowercase characters are mapped to uppercase on input.
X
X Integer literals consist of a sequence of digits optionally beginning
X with a '+' or '-'. The range of values an integer can represent is
X limited by the size of a C 'long' on the machine on which XLISP is
X running.
X
X Floating point literals consist of a sequence of digits optionally
X beginning with a '+' or '-' and including an embedded decimal point.
X The range of values a floating point number can represent is limited
X by the size of a C 'float' ('double' on machines with 32 bit
X addresses) on the machine on which XLISP is running.
X
X Literal strings are sequences of characters surrounded by double
X quotes. Within quoted strings the '\' character is used to allow
X non-printable characters to be included. The codes recognized are:
X
X \\ means the character '\'
X \n means newline
X \t means tab
X \r means return
X \e means escape
X \nnn means the character whose octal code is nnn
X
X XLISP defines several useful read macros:
X
X '<expr> == (quote <expr>)
X #'<expr> == (function <expr>)
X `<expr> == (backquote <expr>)
X ,<expr> == (comma <expr>)
X ,@<expr> == (comma-at <expr>)
X
X
X XLISP: An Experimental Object Oriented Language Page 10
X OBJECTS
X
X
X 8 OBJECTS
X
X Definitions:
X
X o selector - a symbol used to select an appropriate method
X
X o message - a selector and a list of actual arguments
X
X o method - the code that implements a message
X
X Since XLISP was created to provide a simple basis for experimenting
X with object oriented programming, one of the primitive data types
X included is 'object'. In XLISP, an object consists of a data
X structure containing a pointer to the object's class as well as a list
X containing the values of the object's instance variables.
X
X Officially, there is no way to see inside an object (look at the
X values of its instance variables). The only way to communicate with
X an object is by sending it a message. When the XLISP evaluator
X evaluates a list the value of whose first element is an object, it
X interprets the value of the second element of the list (which must be
X a symbol) as the message selector. The evaluator determines the class
X of the receiving object and attempts to find a method corresponding to
X the message selector in the set of messages defined for that class.
X If the message is not found in the object's class and the class has a
X super-class, the search continues by looking at the messages defined
X for the super-class. This process continues from one super-class to
X the next until a method for the message is found. If no method is
X found, an error occurs.
X
X When a method is found, the evaluator binds the receiving object to
X the symbol 'self', binds the class in which the method was found to
X the symbol 'msgclass', and evaluates the method using the remaining
X elements of the original list as arguments to the method. These
X arguments are always evaluated prior to being bound to their
X corresponding formal arguments. The result of evaluating the method
X becomes the result of the expression.
X
X
X XLISP: An Experimental Object Oriented Language Page 11
X OBJECTS
X
X
X 8.1 THE 'Object' CLASS
X
X Classes:
X
X Object THE TOP OF THE CLASS HEIRARCHY
X
X Messages:
X
X :show SHOW AN OBJECT'S INSTANCE VARIABLES
X returns the object
X
X :class RETURN THE CLASS OF AN OBJECT
X returns the class of the object
X
X :isnew THE DEFAULT OBJECT INITIALIZATION ROUTINE
X returns the object
X
X :sendsuper <sel> [<args>]... SEND SUPERCLASS A MESSAGE
X <sel> the message selector
X <args> the message arguments
X returns the result of sending the message
X
X
X XLISP: An Experimental Object Oriented Language Page 12
X OBJECTS
X
X
X 8.2 THE 'Class' CLASS
X
X Class THE CLASS OF ALL OBJECT CLASSES (including itself)
X
X Messages:
X
X :new CREATE A NEW INSTANCE OF A CLASS
X returns the new class object
X
X :isnew <ivars> [<cvars>[<super>]] INITIALIZE A NEW CLASS
X <ivars> the list of instance variables
X <cvars> the list of class variables (default is nil)
X <super> the superclass (default is Object)
X returns the new class object
X
X :answer <msg> <fargs> <code> ADD A MESSAGE TO A CLASS
X <msg> the message symbol
X <fargs> the formal argument list
X this list is of the form:
X ([<farg>]...
X [&optional [<oarg>]...]
X [&rest <rarg>]
X [&aux [<aux>]...])
X where
X <farg> a formal argument
X <oarg> an optional argument (default is nil)
X <rarg> bound to the rest of the arguments
X <aux> a auxiliary variable (set to nil)
X <code> a list of executable expressions
X returns the object
X
X
X When a new instance of a class is created by sending the message
X ':new' to an existing class, the message ':isnew' followed by whatever
X parameters were passed to the ':new' message is sent to the newly
X created object.
X
X When a new class is created by sending the ':new' message to the
X object 'Class', an optional parameter may be specified indicating the
X superclass of the new class. If this parameter is omitted, the new
X class will be a subclass of 'Object'. A class inherits all instance
X variables, class variables, and methods from its super-class.
X
X
X XLISP: An Experimental Object Oriented Language Page 13
X SYMBOLS
X
X
X 9 SYMBOLS
X
X
X o self - the current object (within a message context)
X
X o msgclass - the class in which the current method was found
X
X o *oblist* - the object list
X
X o *keylist* - the keyword list
X
X o *standard-input* - the standard input file
X
X o *standard-output* - the standard output file
X
X o *breakenable* - flag controlling entering the break loop on
X errors
X
X o *tracenable* - flag controlling trace back printout on errors
X and breaks
X
X o *tracelimit* - maximum number of levels of trace back
X information printed on errors and breaks
X
X o *evalhook* - user substitute for the evaluator function
X
X o *applyhook* - (not yet implemented)
X
X o *unbound* - indicator for unbound symbols
X
X
X
X XLISP: An Experimental Object Oriented Language Page 14
X FUNCTION DEFINITIONS
X
X
X 10 FUNCTION DEFINITIONS
X
X 10.1 EVALUATION FUNCTIONS
X
X (eval <expr>) EVALUATE AN XLISP EXPRESSION
X <expr> the expression to be evaluated
X returns the result of evaluating the expression
X
X (apply <fun> <args>) APPLY A FUNCTION TO A LIST OF ARGUMENTS
X <fun> the function to apply (or function symbol)
X <args> the argument list
X returns the result of applying the function to the argument list
X
X (funcall <fun> [<arg>]...) CALL A FUNCTION WITH ARGUMENTS
X <fun> the function to call (or function symbol)
X <arg> arguments to pass to the function
X returns the result of calling the function with the arguments
X
X (quote <expr>) RETURN AN EXPRESSION UNEVALUATED
X <expr> the expression to be quoted (quoted)
X returns <expr> unevaluated
X
X (function <expr>) QUOTE A FUNCTION
X <expr> the function to be quoted (quoted)
X returns a function closure
X
X (backquote <expr>) FILL IN A TEMPLATE
X <expr> the template
X returns a copy of the template with comma and comma-at expressions
X expanded (see the Common Lisp reference manual)
X
X
X XLISP: An Experimental Object Oriented Language Page 15
X SYMBOL FUNCTIONS
X
X
X 10.2 SYMBOL FUNCTIONS
X
X (set <sym> <expr>) SET THE VALUE OF A SYMBOL
X <sym> the symbol being set
X <expr> the new value
X returns the new value
X
X (setq [<sym> <expr>]...) SET THE VALUE OF A SYMBOL
X <sym> the symbol being set (quoted)
X <expr> the new value
X returns the new value
X
X (setf [<place> <expr>]...) SET THE VALUE OF A FIELD
X <place> the field specifier (quoted):
X <sym> set the value of a symbol
X (car <expr>) set the car of a list node
X (cdr <expr>) set the cdr of a list node
X (get <sym> <prop>) set the value of a property
X (symbol-value <sym>) set the value of a symbol
X (symbol-plist <sym>) set the property list of a symbol
X <value> the new value
X returns the new value
X
X (defun <sym> <fargs> [<expr>]...) DEFINE A FUNCTION
X (defmacro <sym> <fargs> [<expr>]...) DEFINE A MACRO
X <sym> symbol being defined (quoted)
X <fargs> list of formal arguments (quoted)
X this list is of the form:
X ([<farg>]...
X [&optional [<oarg>]...]
X [&rest <rarg>]
X [&aux [<aux>]...])
X where
X <farg> is a formal argument
X <oarg> is an optional argument (default is nil)
X <rarg> bound to the rest of the arguments
X <aux> is an auxiliary variable (set to nil)
X <expr> expressions constituting the body of the
X function (quoted)
X returns the function symbol
X
X (gensym [<tag>]) GENERATE A SYMBOL
X <tag> string or number
X returns the new symbol
X
X (intern <pname>) MAKE AN INTERNED SYMBOL
X <pname> the symbol's print name string
X returns the new symbol
X
X (make-symbol <pname>) MAKE AN UNINTERNED SYMBOL
X <pname> the symbol's print name string
X returns the new symbol
X
X
X XLISP: An Experimental Object Oriented Language Page 16
X SYMBOL FUNCTIONS
X
X
X (symbol-name <sym>) GET THE PRINT NAME OF A SYMBOL
X <sym> the symbol
X returns the symbol's print name
X
X (symbol-value <sym>) GET THE VALUE OF A SYMBOL
X <sym> the symbol
X returns the symbol's value
X
X (symbol-plist <sym>) GET THE PROPERTY LIST OF A SYMBOL
X <sym> the symbol
X returns the symbol's property list
X
X
X XLISP: An Experimental Object Oriented Language Page 17
X PROPERTY LIST FUNCTIONS
X
X
X 10.3 PROPERTY LIST FUNCTIONS
X
X (get <sym> <prop>) GET THE VALUE OF A PROPERTY
X <sym> the symbol
X <prop> the property symbol
X returns the property value or nil
X
X (putprop <sym> <val> <prop>) PUT A PROPERTY ONTO THE PROPERTY LIST
X <sym> the symbol
X <val> the property value
X <prop> the property symbol
X returns nil
X
X (remprop <sym> <prop>) REMOVE A PROPERTY
X <sym> the symbol
X <prop> the property symbol
X
X
X XLISP: An Experimental Object Oriented Language Page 18
X LIST FUNCTIONS
X
X
X 10.4 LIST FUNCTIONS
X
X (car <expr>) RETURN THE CAR OF A LIST NODE
X <expr> the list node
X returns the car of the list node
X
X (cdr <expr>) RETURN THE CDR OF A LIST NODE
X <expr> the list node
X returns the cdr of the list node
X
X (caar <expr>) == (car (car <expr>))
X (cadr <expr>) == (car (cdr <expr>))
X (cdar <expr>) == (cdr (car <expr>))
X (cddr <expr>) == (cdr (cdr <expr>))
X
X (cons <expr1> <expr2>) CONSTRUCT A NEW LIST NODE
X <expr1> the car of the new list node
X <expr2> the cdr of the new list node
X returns the new list node
X
X (list [<expr>]...) CREATE A LIST OF VALUES
X <expr> expressions to be combined into a list
X returns the new list
X
X (append [<expr>]...) APPEND LISTS
X <expr> lists whose elements are to be appended
X returns the new list
X
X (reverse <expr>) REVERSE A LIST
X <expr> the list to reverse
X returns a new list in the reverse order
X
X (last <list>) RETURN THE LAST LIST NODE OF A LIST
X <list> the list
X returns the last list node in the list
X
X (member <expr> <list> [<key> <test>]) FIND AN EXPRESSION IN A LIST
X <expr> the expression to find
X <list> the list to search
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the remainder of the list starting with the expression
X
X (assoc <expr> <alist> [<key> <test>]) FIND AN EXPRESSION IN AN A-LIST
X <expr> the expression to find
X <alist> the association list
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the alist entry or nil
X
X
X XLISP: An Experimental Object Oriented Language Page 19
X LIST FUNCTIONS
X
X
X (remove <expr> <list> [<key> <test>]) REMOVE AN EXPRESSION FROM A LIST
X <expr> the expression to delete
X <list> the list
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the list with the matching expressions deleted
X
X (length <expr>) FIND THE LENGTH OF A LIST OR STRING
X <expr> the list or string
X returns the length of the list or string
X
X (nth <n> <list>) RETURN THE NTH ELEMENT OF A LIST
X <n> the number of the element to return (zero origin)
X <list> the list
X returns the nth element or nil if the list isn't that long
X
X (nthcdr <n> <list>) RETURN THE NTH CDR OF A LIST
X <n> the number of the element to return (zero origin)
X <list> the list
X returns the nth cdr or nil if the list isn't that long
X
X (mapc <fcn> <list1> [<list>]...) APPLY FUNCTION TO SUCCESSIVE CARS
X <fcn> the function or function name
X <listn> a list for each argument of the function
X returns the first list of arguments
X
X (mapcar <fcn> <list1> [<list>]...) APPLY FUNCTION TO SUCCESSIVE CARS
X <fcn> the function or function name
X <listn> a list for each argument of the function
X returns the list of values returned by each function invocation
X
X (mapl <fcn> <list1> [<list>]...) APPLY FUNCTION TO SUCCESSIVE CDRS
X <fcn> the function or function name
X <listn> a list for each argument of the function
X returns the first list of arguments
X
X (maplist <fcn> <list1> [<list>]...) APPLY FUNCTION TO SUCCESSIVE CDRS
X <fcn> the function or function name
X <listn> a list for each argument of the function
X returns the list of values returned by each function invocation
X
X
X XLISP: An Experimental Object Oriented Language Page 20
X LIST FUNCTIONS
X
X
X (subst <to> <from> <expr> [<key> <test>]) SUBSTITUTE EXPRESSIONS
X <to> the new expression
X <from> the old expression
X <expr> the expression in which to do the substitutions
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the expression with substitutions
X
X (sublis <alist> <expr> [<key> <test>]) SUBSTITUTE USING AN A-LIST
X <alist> the association list
X <expr> the expression in which to do the substitutions
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the expression with substitutions
X
X
X XLISP: An Experimental Object Oriented Language Page 21
X DESTRUCTIVE LIST FUNCTIONS
X
X
X 10.5 DESTRUCTIVE LIST FUNCTIONS
X
X (rplaca <list> <expr>) REPLACE THE CAR OF A LIST NODE
X <list> the list node
X <expr> the new value for the car of the list node
X returns the list node after updating the car
X
X (rplacd <list> <expr>) REPLACE THE CDR OF A LIST NODE
X <list> the list node
X <expr> the new value for the cdr of the list node
X returns the list node after updating the cdr
X
X (nconc [<list>]...) DESTRUCTIVELY CONCATENATE LISTS
X <list> lists to concatenate
X returns the result of concatenating the lists
X
X (delete <expr> <list> [<key> <test>]) DELETE AN EXPRESSION FROM A LIST
X <expr> the expression to delete
X <list> the list
X <key> the keyword :test or :test-not
X <test> the test function (defaults to eql)
X returns the list with the matching expressions deleted
X
X
X XLISP: An Experimental Object Oriented Language Page 22
X PREDICATE FUNCTIONS
X
X
X 10.6 PREDICATE FUNCTIONS
X
X (atom <expr>) IS THIS AN ATOM?
X <expr> the expression to check
X returns t if the value is an atom, nil otherwise
X
X (symbolp <expr>) IS THIS A SYMBOL?
X <expr> the expression to check
X returns t if the expression is a symbol, nil otherwise
X
X (numberp <expr>) IS THIS A NUMBER?
X <expr> the expression to check
X returns t if the expression is a number, nil otherwise
X
X (null <expr>) IS THIS AN EMPTY LIST?
X <expr> the list to check
X returns t if the list is empty, nil otherwise
X
X (not <expr>) IS THIS FALSE?
X <expr> the expression to check
X return t if the expression is nil, nil otherwise
X
X (listp <expr>) IS THIS A LIST?
X <expr> the expression to check
X returns t if the value is a list node or nil, nil otherwise
X
X (consp <expr>) IS THIS A NON-EMPTY LIST?
X <expr> the expression to check
X returns t if the value is a list node, nil otherwise
X
X (boundp <sym>) IS THIS A BOUND SYMBOL?
X <sym> the symbol
X returns t if a value is bound to the symbol, nil otherwise
X
X
X XLISP: An Experimental Object Oriented Language Page 23
X PREDICATE FUNCTIONS
X
X
X (minusp <expr>) IS THIS NUMBER NEGATIVE?
X <expr> the number to test
X returns t if the number is negative, nil otherwise
X
X (zerop <expr>) IS THIS NUMBER ZERO?
X <expr> the number to test
X returns t if the number is zero, nil otherwise
X
X (plusp <expr>) IS THIS NUMBER POSITIVE?
X <expr> the number to test
X returns t if the number is positive, nil otherwise
X
X (evenp <expr>) IS THIS NUMBER EVEN?
X <expr> the number to test
X returns t if the number is even, nil otherwise
X
X (oddp <expr>) IS THIS NUMBER ODD?
X <expr> the number to test
X returns t if the number is odd, nil otherwise
X
X (eq <expr1> <expr2>) ARE THE EXPRESSIONS IDENTICAL?
X <expr1> the first expression
X <expr2> the second expression
X returns t if they are equal, nil otherwise
X
X (eql <expr1> <expr2>) ARE THE EXPRESSIONS IDENTICAL?
X (WORKS WITH NUMBERS AND STRINGS)
X <expr1> the first expression
X <expr2> the second expression
X returns t if they are equal, nil otherwise
X
X (equal <expr1> <expr2>) ARE THE EXPRESSIONS EQUAL?
X <expr1> the first expression
X <expr2> the second expression
X returns t if they are equal, nil otherwise
X
X
X XLISP: An Experimental Object Oriented Language Page 24
X CONTROL FUNCTIONS
X
X
X 10.7 CONTROL FUNCTIONS
X
X (cond [<pair>]...) EVALUATE CONDITIONALLY
X <pair> pair consisting of:
X (<pred> [<expr>]...)
X where
X <pred> is a predicate expression
X <expr> evaluated if the predicate
X is not nil
X returns the value of the first expression whose predicate
X is not nil
X
X (and [<expr>]...) THE LOGICAL AND OF A LIST OF EXPRESSIONS
X <expr> the expressions to be ANDed
X returns nil if any expression evaluates to nil,
X otherwise the value of the last expression
X (evaluation of expressions stops after the first
X expression that evaluates to nil)
X
X (or [<expr>]...) THE LOGICAL OR OF A LIST OF EXPRESSIONS
X <expr> the expressions to be ORed
X returns nil if all expressions evaluate to nil,
X otherwise the value of the first non-nil expression
X (evaluation of expressions stops after the first
X expression that does not evaluate to nil)
X
X (if <texpr> <expr1> [<expr2>]) EXECUTE EXPRESSIONS CONDITIONALLY
X <texpr> the test expression
X <expr1> the expression to be evaluated if texpr is non-nil
X <expr2> the expression to be evaluated if texpr is nil
X returns the value of the selected expression
X
X (let ([<binding>]...) [<expr>]...) BIND SYMBOLS AND EVALUATE EXPRESSIONS
X (let* ([<binding>]...) [<expr>]...) LET WITH SEQUENTIAL BINDING
X <binding> the variable bindings each of which is either:
X 1) a symbol (which is initialized to nil)
X 2) a list whose car is a symbol and whose cadr
X is an initialization expression
X <expr> the expressions to be evaluated
X returns the value of the last expression
X
X (catch <sym> [<expr>]...) EVALUATE EXPRESSIONS AND CATCH THROWS
X <sym> the catch tag
X <expr> expressions to evaluate
X returns the value of the last expression the throw expression
X
X (throw <sym> [<expr>]) THROW TO A CATCH
X <sym> the catch tag
X <expr> the value for the catch to return (defaults to nil)
X returns never returns
X
X
X XLISP: An Experimental Object Oriented Language Page 25
X LOOPING FUNCTIONS
X
X
X 10.8 LOOPING FUNCTIONS
X
X (do ([<binding>]...) (<texpr> [<rexpr>]...) [<expr>]...)
X (do* ([<binding>]...) (<texpr> [<rexpr>]...) [<expr>]...)
X <binding> the variable bindings each of which is either:
X 1) a symbol (which is initialized to nil)
X 2) a list of the form: (<sym> <init> [<step>])
X where:
X <sym> is the symbol to bind
X <init> is the initial value of the symbol
X <step> is a step expression
X <texpr> the termination test expression
X <rexpr> result expressions (the default is nil)
X <expr> the body of the loop (treated like an implicit prog)
X returns the value of the last result expression
X
X (dolist (<sym> <expr> [<rexpr>]) [<expr>]...) LOOP THROUGH A LIST
X <sym> the symbol to bind to each list element
X <expr> the list expression
X <rexpr> the result expression (the default is nil)
X <expr> the body of the loop (treated like an implicit prog)
X
X (dotimes (<sym> <expr> [<rexpr>]) [<expr>]...) LOOP FROM ZERO TO N-1
X <sym> the symbol to bind to each value from 0 to n-1
X <expr> the number of times to loop
X <rexpr> the result expression (the default is nil)
X <expr> the body of the loop (treated like an implicit prog)
X
X
X XLISP: An Experimental Object Oriented Language Page 26
X THE PROGRAM FEATURE
X
X
X 10.9 THE PROGRAM FEATURE
X
X (prog ([<binding>]...) [<expr>]...) THE PROGRAM FEATURE
X (prog* ([<binding>]...) [<expr>]...) PROG WITH SEQUENTIAL BINDING
X <binding> the variable bindings each of which is either:
X 1) a symbol (which is initialized to nil)
X 2) a list whose car is a symbol and whose cadr
X is an initialization expression
X <expr> expressions to evaluate or tags (symbols)
X returns nil or the argument passed to the return function
X
X (go <sym>) GO TO A TAG WITHIN A PROG CONSTRUCT
X <sym> the tag (quoted)
X returns never returns
X
X (return [<expr>]) CAUSE A PROG CONSTRUCT TO RETURN A VALUE
X <expr> the value (defaults to nil)
X returns never returns
X
X (prog1 <expr1> [<expr>]...) EXECUTE EXPRESSIONS SEQUENTIALLY
X <expr1> the first expression to evaluate
X <expr> the remaining expressions to evaluate
X returns the value of the first expression
X
X (prog2 <expr1> <expr2> [<expr>]...) EXECUTE EXPRESSIONS SEQUENTIALLY
X <expr1> the first expression to evaluate
X <expr2> the second expression to evaluate
X <expr> the remaining expressions to evaluate
X returns the value of the second expression
X
X (progn [<expr>]...) EXECUTE EXPRESSIONS SEQUENTIALLY
X <expr> the expressions to evaluate
X returns the value of the last expression (or nil)
X
X
X XLISP: An Experimental Object Oriented Language Page 27
X DEBUGGING AND ERROR HANDLING
X
X
X 10.10 DEBUGGING AND ERROR HANDLING
X
X (error <emsg> [<arg>]) SIGNAL A NON-CORRECTABLE ERROR
X <emsg> the error message string
X <arg> the argument expression (printed after the message)
X returns never returns
X
X (cerror <cmsg> <emsg> [<arg>]) SIGNAL A CORRECTABLE ERROR
X <cmsg> the continue message string
X <emsg> the error message string
X <arg> the argument expression (printed after the message)
X returns nil when continued from the break loop
X
X (break [<bmsg> [<arg>]]) ENTER A BREAK LOOP
X <bmsg> the break message string (defaults to "**BREAK**")
X <arg> the argument expression (printed after the message)
X returns nil when continued from the break loop
X
X (clean-up) CLEAN-UP AFTER AN ERROR
X returns never returns
X
X (continue) CONTINUE FROM A CORRECTABLE ERROR
X returns never returns
X
X (errset <expr> [<pflag>]) TRAP ERRORS
X <expr> the expression to execute
X <pflag> flag to control printing of the error message
X returns the value of the last expression consed with nil
X or nil on error
X
X (baktrace [<n>]) PRINT N LEVELS OF TRACE BACK INFORMATION
X <n> the number of levels (defaults to all levels)
X returns nil
X
X (evalhook <expr> <ehook> <ahook>) EVALUATE AN EXPRESSION WITH HOOKS
X <expr> the expression to evaluate
X <ehook> the value for *evalhook*
X <ahook> the value for *applyhook*
X returns the result of evaluating the expression
X
X
X XLISP: An Experimental Object Oriented Language Page 28
X ARITHMETIC FUNCTIONS
X
X
X 10.11 ARITHMETIC FUNCTIONS
X
X (truncate <expr>) TRUNCATES A FLOATING POINT NUMBER TO AN INTEGER
X <expr> the number
X returns the result of truncating the number
X
X (float <expr>) CONVERTS AN INTEGER TO A FLOATING POINT NUMBER
X <expr> the number
X returns the result of floating the integer
X
X (+ <expr>...) ADD A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the addition
X
X (- <expr>...) SUBTRACT A LIST OF NUMBERS OR NEGATE A SINGLE NUMBER
X <expr> the numbers
X returns the result of the subtraction
X
X (* <expr>...) MULTIPLY A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the multiplication
X
X (/ <expr>...) DIVIDE A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the division
X
X (1+ <expr>) ADD ONE TO A NUMBER
X <expr> the number
X returns the number plus one
X
X (1- <expr>) SUBTRACT ONE FROM A NUMBER
X <expr> the number
X returns the number minus one
X
X (rem <expr>...) REMAINDER OF A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the remainder operation
X
X (min <expr>...) THE SMALLEST OF A LIST OF NUMBERS
X <expr> the expressions to be checked
X returns the smallest number in the list
X
X (max <expr>...) THE LARGEST OF A LIST OF NUMBERS
X <expr> the expressions to be checked
X returns the largest number in the list
X
X (abs <expr>) THE ABSOLUTE VALUE OF A NUMBER
X <expr> the number
X returns the absolute value of the number
X
X
X XLISP: An Experimental Object Oriented Language Page 29
X ARITHMETIC FUNCTIONS
X
X
X (sin <expr>) COMPUTE THE SINE OF A NUMBER
X <expr> the floating point number
X returns the sine of the number
X
X (cos <expr>) COMPUTE THE COSINE OF A NUMBER
X <expr> the floating point number
X returns the cosine of the number
X
X (tan <expr>) COMPUTE THE TANGENT OF A NUMBER
X <expr> the floating point number
X returns the tangent of the number
X
X (expt <x-expr> <y-expr>) COMPUTE X TO THE Y POWER
X <x-expr> the floating point number
X <y-expr> the floating point exponent
X returns x to the y power
X
X (exp <x-expr>) COMPUTE E TO THE X POWER
X <x-expr> the floating point number
X returns e to the x power
X
X (sqrt <expr>) COMPUTE THE SQUARE ROOT OF A NUMBER
X <expr> the floating point number
X returns the square root of the number
X
X
X XLISP: An Experimental Object Oriented Language Page 30
X BITWISE LOGICAL FUNCTIONS
X
X
X 10.12 BITWISE LOGICAL FUNCTIONS
X
X (bit-and <expr>...) THE BITWISE AND OF A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the and operation
X
X (bit-ior <expr>...) THE BITWISE INCLUSIVE OR OF A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the inclusive or operation
X
X (bit-xor <expr>...) THE BITWISE EXCLUSIVE OR OF A LIST OF NUMBERS
X <expr> the numbers
X returns the result of the exclusive or operation
X
X (bit-not <expr>) THE BITWISE NOT OF A NUMBER
X <expr> the number
X returns the bitwise inversion of number
X
X
X XLISP: An Experimental Object Oriented Language Page 31
X RELATIONAL FUNCTIONS
X
X
X 10.13 RELATIONAL FUNCTIONS
X
X The relational functions can be used to compare integers, floating
X point numbers or strings.
X
X (< <e1> <e2>) TEST FOR LESS THAN
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X (<= <e1> <e2>) TEST FOR LESS THAN OR EQUAL TO
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X (= <e1> <e2>) TEST FOR EQUAL TO
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X (/= <e1> <e2>) TEST FOR NOT EQUAL TO
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X (>= <e1> <e2>) TEST FOR GREATER THAN OR EQUAL TO
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X (> <e1> <e2>) TEST FOR GREATER THAN
X <e1> the left operand of the comparison
X <e2> the right operand of the comparison
X returns the result of comparing <e1> with <e2>
X
X
X XLISP: An Experimental Object Oriented Language Page 32
X STRING FUNCTIONS
X
X
X 10.14 STRING FUNCTIONS
X
X (char <string> <index>) EXTRACT A CHARACTER FROM A STRING
X <string> the string
X <index> the string index (zero relative)
X returns the ascii code of the first character
X
X (string <expr>) MAKE A STRING FROM AN INTEGER ASCII VALUE
X <expr> the numeric expression
X returns a one character string whose first character is <expr>
X
X (strcat [<expr>]...) CONCATENATE STRINGS
X <expr> the strings to concatenate
X returns the result of concatenating the strings
X
X (substr <expr> <sexpr> [<lexpr>]) EXTRACT A SUBSTRING
X <expr> the string
X <sexpr> the starting position
X <lexpr> the length (default is rest of string)
X returns substring starting at <sexpr> for <lexpr>
X
X
X XLISP: An Experimental Object Oriented Language Page 33
X INPUT/OUTPUT FUNCTIONS
X
X
X 10.15 INPUT/OUTPUT FUNCTIONS
X
X (read [<source> [<eof>]]) READ AN XLISP EXPRESSION
X <source> the input source (default is standard input)
X <eof> the value to return on end of file (default is nil)
X returns the expression read
X
X (print <expr> [<sink>]) PRINT A LIST OF VALUES ON A NEW LINE
X <expr> the expressions to be printed
X <sink> the output sink (default is standard output)
X returns the expression
X
X (prin1 <expr> [<sink>]) PRINT A LIST OF VALUES
X <expr> the expressions to be printed
X <sink> the output sink (default is standard output)
X returns the expression
X
X (princ <expr> [<sink>]) PRINT A LIST OF VALUES WITHOUT QUOTING
X <expr> the expressions to be printed
X <sink> the output sink (default is standard output)
X returns the expression
X
X (terpri [<sink>]) TERMINATE THE CURRENT PRINT LINE
X <sink> the output sink (default is standard output)
X returns nil
X
X (flatsize <expr>) LENGTH OF PRINTED REPRESENTATION USING PRIN1
X <expr> the expression
X returns the length
X
X (flatc <expr>) LENGTH OF PRINTED REPRESENTATION USING PRINC
X <expr> the expression
X returns the length
X
X
X
X XLISP: An Experimental Object Oriented Language Page 34
X FILE I/O FUNCTIONS
X
X
X 10.16 FILE I/O FUNCTIONS
X
X (openi <fname>) OPEN AN INPUT FILE
X <fname> the file name string
X returns a file pointer
X
X (openo <fname>) OPEN AN OUTPUT FILE
X <fname> the file name string
X returns a file pointer
X
X (close <fp>) CLOSE A FILE
X <fp> the file pointer
X returns nil
X
X (read-char [<source>]) READ A CHARACTER FROM A FILE OR STREAM
X <source> the input source (default is standard input)
X returns the character (integer)
X
X (peek-char [<flag> [<source>]]) PEEK AT THE NEXT CHARACTER
X <flag> flag for skipping white space (default is nil)
X <source> the input source (default is standard input)
X returns the character (integer)
X
X (write-char <ch> [<sink>]) WRITE A CHARACTER TO A FILE OR STREAM
X <ch> the character to put (integer)
X <sink> the output sink (default is standard output)
X returns the character (integer)
X
X (read-line [<source>]) READ A LINE FROM A FILE OR STREAM
X <source> the input source (default is standard input)
X returns the input string
X
X
X XLISP: An Experimental Object Oriented Language Page 35
X SYSTEM FUNCTIONS
X
X
X 10.17 SYSTEM FUNCTIONS
X
X (load <fname> [<vflag> [<pflag>]]) LOAD AN XLISP SOURCE FILE
X <fname> the filename string (in double quotes)
X <vflag> the verbose flag (default is t)
X <pflag> the print flag (default is nil)
X returns the filename
X
X (gc) FORCE GARBAGE COLLECTION
X returns nil
X
X (expand <num>) EXPAND MEMORY BY ADDING SEGMENTS
X <num> the number of segments to add
X returns the number of segments added
X
X (alloc <num>) CHANGE NUMBER OF NODES TO ALLOCATE IN EACH SEGMENT
X <num> the number of nodes to allocate
X returns the old number of nodes to allocate
X
X (mem) SHOW MEMORY ALLOCATION STATISTICS
X returns nil
X
X (type-of <expr>) RETURNS THE TYPE OF THE EXPRESSION
X <expr> the expression to return the type of
X returns nil if the value is nil otherwise one of the symbols:
X :SYMBOL for symbols
X :OBJECT for objects
X :CONS for list nodes
X :SUBR for subroutines with evaluated arguments
X :FSUBR for subroutines with unevaluated arguments
X :STRING for string nodes
X :FIXNUM for integer nodes
X :FLONUM for floating point nodes
X :FILE for file pointer nodes
X
X (exit) EXIT XLISP
X returns never returns
SHAR_EOF
if test 53933 -ne "`wc -c 'xlisp.doc'`"
then
echo shar: error transmitting "'xlisp.doc'" '(should have been 53933 characters)'
fi
echo shar: extracting "'read.me'" '(2236 characters)'
if test -f 'read.me'
then
echo shar: over-writing existing file "'read.me'"
fi
sed 's/^X//' << \SHAR_EOF > 'read.me'
XThis distribution of xlisp contains the following files:
X
Xread.me This file
Xxlisp.doc The documentation
X
Xinit.lsp Required initialization file. Automatically loaded by
X xlisp on startup. Must be in the same folder
X (directory) as xlisp.ttp, unless INITPATH is defined
X in xlisp.h. (INITPATH if the filename for init.lsp
X not the directory name ie. "mypath\\init.lsp" and NOT
X just "mypath\\".
X
X Sample xlisp programs:
Xart.lsp example.lsp fact.lsp fib.lsp hanoi.lsp hdwr.lsp ifthen.lsp
Xprolog.lsp queens.lsp queens2.lsp
X
Xmakefile To make xlisp on the Vax (unix) (also see xlisp.h)
X
Xctype.h math.h setjmp.h:
X These .h files are for the St only. When making xlisp
X on the Vax (unix) hide these files by moving them to
X another directory.
X
X
Xxlisp.h Edit first line in the file for system type (ST or Unix)
X
X Source
Xststuff.c xlbfun.c xlcont.c xldbug.c xldmem.c xleval.c xlfio.c xlftab1.c
Xxlftab2.c xlglob.c xlinit.c xlio.c xlisp.c xljump.c xllist.c xlmath.c
Xxlobj.c xlprin.c xlread.c xlstr.c xlsubr.c xlsym.c xlsys.c
X The file ststuff.c is St specific and is not used
X by the Vax (unix) version.
X
X
Xxlisp.bat xlisp.inp:
X Batch file to link and relmod xlisp on the St
X
XHow to Make xlisp on the ST
X Compile all the .c files after editing xlisp.h appropriately.
XThen link using xlisp.bat. (You will probably have to edit xlisp.bat
Xto set up the drive designator appropriately for your system). Rename
Xxlisp.prg to xlisp.ttp.
X
XTo invoke xlisp from the desktop on the ST double click xlisp.ttp. In the
Xdialog box enter the name(s) of the file(s) you want loaded (don't enter
Xthe .lsp extention). You may ofcourse choose to supply no filenames in
Xthe dialog box, in which case simply hit <return>. xlisp.ttp will
Xautomatically load init.lsp, and then the file(s).
X
XTo load a file from the interpreter issue:
X(load "filename.lsp")
XNotice the ".lsp" extention is required to be entered here.
X
XHow to Make xlisp on a Vax
X Edit xlisp.h and makefile appropriately and then issue the
Xcommand:
X make install
X
XQuestions: Send electronic mail to the address below.
X
X enjoy
X
X Jwahar R. Bammi
X Usenet: .....!decvax!cwruecmp!bammi
X CSnet: bammi@case
X Arpa: bammi%case@csnet-relay
X CompuServe: 71515,155
SHAR_EOF
if test 2236 -ne "`wc -c 'read.me'`"
then
echo shar: error transmitting "'read.me'" '(should have been 2236 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# makefile
# ctype.h
# math.h
# setjmp.h
# xlisp.h
# xlisp.bat
# xlisp.inp
# This archive created: Sat Jan 18 14:32:21 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'makefile'" '(618 characters)'
if test -f 'makefile'
then
echo shar: over-writing existing file "'makefile'"
fi
sed 's/^X//' << \SHAR_EOF > 'makefile'
X# BIN is the directory where you want the executable to go
XBIN = /u/bammi/etc/bin
X
XSRC = xlbfun.c xlcont.c xldbug.c xldmem.c xleval.c xlfio.c xlftab1.c \
Xxlftab2.c xlglob.c xlinit.c xlio.c xlisp.c xljump.c xllist.c xlmath.c \
Xxlobj.c xlprin.c xlread.c xlstr.c xlsubr.c xlsym.c xlsys.c
X
XOBJ = xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o xlftab1.o \
Xxlftab2.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o \
Xxlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o
X
XCFLAGS= -O
X
Xxlisp: $(OBJ)
X cc -O -o xlisp $(OBJ) -lm -s
X
Xinstall: xlisp
X cp xlisp $(BIN)
X cp init.lsp $(BIN)
X
Xclean:
X rm -f *.o
X
SHAR_EOF
if test 618 -ne "`wc -c 'makefile'`"
then
echo shar: error transmitting "'makefile'" '(should have been 618 characters)'
fi
echo shar: extracting "'ctype.h'" '(260 characters)'
if test -f 'ctype.h'
then
echo shar: over-writing existing file "'ctype.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'ctype.h'
X
X#define isupper(ch) ((ch) >= 'A' && (ch) <= 'Z')
X#define islower(ch) ((ch) >= 'a' && (ch) <= 'z')
X#define toupper(ch) ((ch) - 'a' + 'A')
X#define tolower(ch) ((ch) - 'A' + 'a')
X#define isdigit(ch) ((ch) >= '0' && (ch) <= '9')
X#define isspace(ch) ((ch) <= ' ')
SHAR_EOF
if test 260 -ne "`wc -c 'ctype.h'`"
then
echo shar: error transmitting "'ctype.h'" '(should have been 260 characters)'
fi
echo shar: extracting "'math.h'" '(45 characters)'
if test -f 'math.h'
then
echo shar: over-writing existing file "'math.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'math.h'
Xdouble sin(),cos(),tan(),exp(),pow(),sqrt();
SHAR_EOF
if test 45 -ne "`wc -c 'math.h'`"
then
echo shar: error transmitting "'math.h'" '(should have been 45 characters)'
fi
echo shar: extracting "'setjmp.h'" '(26 characters)'
if test -f 'setjmp.h'
then
echo shar: over-writing existing file "'setjmp.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'setjmp.h'
Xtypedef long jmp_buf[16];
SHAR_EOF
if test 26 -ne "`wc -c 'setjmp.h'`"
then
echo shar: error transmitting "'setjmp.h'" '(should have been 26 characters)'
fi
echo shar: extracting "'xlisp.h'" '(9596 characters)'
if test -f 'xlisp.h'
then
echo shar: over-writing existing file "'xlisp.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.h'
X/* xlisp - a small subset of lisp */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X/* >>>>>>>>>>>>>>>>>>>>>> SYSTEM SPECIFIC DEFINITIONS <<<<<<<<<<<<<<<<<<<<<< */
X/* >>>>>>>>>>>>>>>>>>>>>> BEGIN <<<<<<<<<<<<<<<<<<<<<< */
X
X/* system specific definitions - Edit and uncomment one of the two */
X#define ATARI
X/* #define unix */
X
X/* Define INITPATH if you want the initialization file in a specific directory
X * for example
X * #define INITPATH "/u/bammi/etc/lib/init.lsp" on the Vax
X * or
X * #define INITPATH "A:\\mydir\\init.lsp" on the ST and so on.
X */
X
X/* >>>>>>>>>>>>>>>>>>>>>> END <<<<<<<<<<<<<<<<<<<<<< */
X/* >>>>>>>>>>>>>>>>>>>>>> SYSTEM SPECIFIC DEFINITIONS <<<<<<<<<<<<<<<<<<<<<< */
X
X
X
X
X
X#include <stdio.h>
X#include <ctype.h>
X#ifndef MEGAMAX
X#include <setjmp.h>
X#endif
X
X/* NNODES number of nodes to allocate in each request (200) */
X/* TDEPTH trace stack depth (100) */
X/* FORWARD type of a forward declaration () */
X/* LOCAL type of a local function (static) */
X/* AFMT printf format for addresses ("%x") */
X/* FIXNUM data type for fixed point numbers (long) */
X/* ITYPE return type for fixed point conversion routine (long) */
X/* ICNV fixed point input conversion routine (atol) */
X/* IFMT printf format for fixed point numbers ("%ld") */
X/* FLONUM data type for floating point numbers (float) */
X/* FTYPE return type for floating point conversion routine (double) */
X/* FCNV floating point input conversion routine (atof) */
X/* FFMT printf format for floating point numbers ("%f") */
X
X/* for the Computer Innovations compiler */
X#ifdef CI
X#define NNODES 1000
X#define TDEPTH 500
X#define ITYPE double atoi()
X#define ICNV(n) atoi(n)
X#define NIL 0
X#endif
X
X/* for the CPM68K compiler */
X#ifdef CPM68K
X#define NNODES 1000
X#define TDEPTH 500
X#define LOCAL
X#define AFMT "%lx"
X#define FLONUM double
X#undef NULL
X#define NULL 0L
X#endif
X
X/* for the Atari 520ST (DRI C Compiler) */
X#ifdef ATARI
X#define NNODES 1000
X#define TDEPTH 500
X#define LOCAL
X#define AFMT "%lx"
X#define FLONUM double
X#undef NULL
X#define NULL 0L
X#define getc(fp) stgetc(fp)
X#define putc(ch,fp) stputc(ch,fp)
X#endif
X
X/* for the DeSmet compiler */
X#ifdef DESMET
X#define NNODES 1000
X#define TDEPTH 500
X#define LOCAL
X#define getc(fp) getcx(fp)
X#define putc(ch,fp) putcx(ch,fp)
X#define EOF -1
X#endif
X
X/* for the MegaMax compiler */
X#ifdef MEGAMAX
X#define NNODES 1000
X#define TDEPTH 500
X#define TSTKSIZE (4 * TDEPTH)
X#define LOCAL
X#define AFMT "%lx"
X#define getc(fp) macgetc(fp)
X#define putc(ch,fp) macputc(ch,fp)
X#endif
X
X/* for the VAX-11 C compiler */
X#ifdef vms
X#define NNODES 2000
X#define TDEPTH 1000
X#endif
X
X/* for the DECUS C compiler */
X#ifdef decus
X#define NNODES 200
X#define TDEPTH 100
X#define FORWARD extern
X#endif
X
X/* for unix compilers */
X#ifdef unix
X#define NNODES 200
X#define TDEPTH 100
X#endif
X
X/* for the AZTEC C compiler (8086) */
X#ifdef AZTEC
X#define NNODES 1000
X#define TDEPTH 500
X#define FLONUM double
X#define getc(fp) agetc(fp)
X#define putc(ch,fp) aputc(ch,fp)
X#define NIL 0
X#endif
X
X/* default important definitions */
X#ifndef NNODES
X#define NNODES 200
X#endif
X#ifndef TDEPTH
X#define TDEPTH 100
X#endif
X#ifndef FORWARD
X#define FORWARD
X#endif
X#ifndef LOCAL
X#define LOCAL static
X#endif
X#ifndef AFMT
X#define AFMT "%x"
X#endif
X#ifndef FIXNUM
X#define FIXNUM long
X#endif
X#ifndef ITYPE
X#define ITYPE long atol()
X#endif
X#ifndef ICNV
X#define ICNV(n) atol(n)
X#endif
X#ifndef IFMT
X#define IFMT "%ld"
X#endif
X#ifndef FLONUM
X#define FLONUM float
X#endif
X#ifndef FTYPE
X#define FTYPE double atof()
X#endif
X#ifndef FCNV
X#define FCNV(n) atof(n)
X#endif
X#ifndef FFMT
X#define FFMT "%f"
X#endif
X#ifndef TSTKSIZE
X#define TSTKSIZE (sizeof(NODE *) * TDEPTH)
X#endif
X
X/* useful definitions */
X#define TRUE 1
X#define FALSE 0
X#ifndef NIL
X#define NIL (NODE *)0
X#endif
X
X/* absolute value macros */
X#define abs(n) ((n) < 0 ? -(n) : (n))
X#define fabs(n) ((n) < 0.0 ? -(n) : (n))
X
X/* program limits */
X#define STRMAX 100 /* maximum length of a string constant */
X
X/* node types */
X#define FREE 0
X#define SUBR 1
X#define FSUBR 2
X#define LIST 3
X#define SYM 4
X#define INT 5
X#define STR 6
X#define OBJ 7
X#define FPTR 8
X#define FLOAT 9
X
X/* node flags */
X#define MARK 1
X#define LEFT 2
X
X/* string types */
X#define DYNAMIC 0
X#define STATIC 1
X
X/* new node access macros */
X#define ntype(x) ((x)->n_type)
X#define atom(x) ((x) == NIL || (x)->n_type != LIST)
X#define null(x) ((x) == NIL)
X#define listp(x) ((x) == NIL || (x)->n_type == LIST)
X#define consp(x) ((x) && (x)->n_type == LIST)
X#define subrp(x) ((x) && (x)->n_type == SUBR)
X#define fsubrp(x) ((x) && (x)->n_type == FSUBR)
X#define stringp(x) ((x) && (x)->n_type == STR)
X#define symbolp(x) ((x) && (x)->n_type == SYM)
X#define filep(x) ((x) && (x)->n_type == FPTR)
X#define objectp(x) ((x) && (x)->n_type == OBJ)
X#define fixp(x) ((x) && (x)->n_type == INT)
X#define floatp(x) ((x) && (x)->n_type == FLOAT)
X#define car(x) ((x)->n_car)
X#define cdr(x) ((x)->n_cdr)
X#define rplaca(x,y) ((x)->n_car = (y))
X#define rplacd(x,y) ((x)->n_cdr = (y))
X#define getvalue(x) ((x)->n_symvalue)
X#define setvalue(x,v) ((x)->n_symvalue = (v))
X
X/* symbol node */
X#define n_symplist n_info.n_xsym.xsy_plist
X#define n_symvalue n_info.n_xsym.xsy_value
X
X/* subr/fsubr node */
X#define n_subr n_info.n_xsubr.xsu_subr
X
X/* list node */
X#define n_car n_info.n_xlist.xl_car
X#define n_cdr n_info.n_xlist.xl_cdr
X#define n_ptr n_info.n_xlist.xl_car
X
X/* integer node */
X#define n_int n_info.n_xint.xi_int
X
X/* float node */
X#define n_float n_info.n_xfloat.xf_float
X
X/* string node */
X#define n_str n_info.n_xstr.xst_str
X#define n_strtype n_info.n_xstr.xst_type
X
X/* object node */
X#define n_obclass n_info.n_xobj.xo_obclass
X#define n_obdata n_info.n_xobj.xo_obdata
X
X/* file pointer node */
X#define n_fp n_info.n_xfptr.xf_fp
X#define n_savech n_info.n_xfptr.xf_savech
X
X/* node structure */
Xtypedef struct node {
X char n_type; /* type of node */
X char n_flags; /* flag bits */
X union { /* value */
X struct xsym { /* symbol node */
X struct node *xsy_plist; /* symbol plist - (name . plist) */
X struct node *xsy_value; /* the current value */
X } n_xsym;
X struct xsubr { /* subr/fsubr node */
X struct node *(*xsu_subr)(); /* pointer to an internal routine */
X } n_xsubr;
X struct xlist { /* list node (cons) */
X struct node *xl_car; /* the car pointer */
X struct node *xl_cdr; /* the cdr pointer */
X } n_xlist;
X struct xint { /* integer node */
X FIXNUM xi_int; /* integer value */
X } n_xint;
X struct xfloat { /* float node */
X FLONUM xf_float; /* float value */
X } n_xfloat;
X struct xstr { /* string node */
X int xst_type; /* string type */
X char *xst_str; /* string pointer */
X } n_xstr;
X struct xobj { /* object node */
X struct node *xo_obclass; /* class of object */
X struct node *xo_obdata; /* instance data */
X } n_xobj;
X struct xfptr { /* file pointer node */
X FILE *xf_fp; /* the file pointer */
X int xf_savech; /* lookahead character for input files */
X } n_xfptr;
X } n_info;
X} NODE;
X
X/* execution context flags */
X#define CF_GO 1
X#define CF_RETURN 2
X#define CF_THROW 4
X#define CF_ERROR 8
X#define CF_CLEANUP 16
X#define CF_CONTINUE 32
X
X/* execution context */
Xtypedef struct context {
X int c_flags; /* context type flags */
X struct node *c_expr; /* expression (type dependant) */
X jmp_buf c_jmpbuf; /* longjmp context */
X struct context *c_xlcontext; /* old value of xlcontext */
X struct node *c_xlstack; /* old value of xlstack */
X struct node *c_xlenv; /* old value of xlenv */
X int c_xltrace; /* old value of xltrace */
X} CONTEXT;
X
X/* function table entry structure */
Xstruct fdef {
X char *f_name; /* function name */
X int f_type; /* function type SUBR/FSUBR */
X struct node *(*f_fcn)(); /* function code */
X};
X
X/* memory segment structure definition */
Xstruct segment {
X int sg_size;
X struct segment *sg_next;
X struct node sg_nodes[1];
X};
X
X/* external procedure declarations */
Xextern struct node *xleval(); /* evaluate an expression */
Xextern struct node *xlapply(); /* apply a function to arguments */
Xextern struct node *xlevlist(); /* evaluate a list of arguments */
Xextern struct node *xlarg(); /* fetch an argument */
Xextern struct node *xlevarg(); /* fetch and evaluate an argument */
Xextern struct node *xlmatch(); /* fetch an typed argument */
Xextern struct node *xlevmatch(); /* fetch and evaluate a typed arg */
Xextern struct node *xlgetfile(); /* fetch a file/stream argument */
Xextern struct node *xlsend(); /* send a message to an object */
Xextern struct node *xlenter(); /* enter a symbol */
Xextern struct node *xlsenter(); /* enter a symbol with a static pname */
Xextern struct node *xlmakesym(); /* make an uninterned symbol */
Xextern struct node *xlsave(); /* generate a stack frame */
Xextern struct node *xlframe(); /* establish a new environment frame */
Xextern struct node *xlgetvalue(); /* get value of a symbol (checked) */
Xextern struct node *xlxgetvalue(); /* get value of a symbol */
Xextern struct node *xlygetvalue(); /* get value of a symbol (no ivars) */
X
Xextern struct node *cvfixnum(); /* convert a fixnum */
Xextern struct node *cvflonum(); /* convert a flonum */
X
Xextern struct node *xlgetprop(); /* get the value of a property */
Xextern char *xlsymname(); /* get the print name of a symbol */
X
Xextern struct node *newnode(); /* allocate a new node */
Xextern char *stralloc(); /* allocate string space */
Xextern char *strsave(); /* make a safe copy of a string */
X
SHAR_EOF
if test 9596 -ne "`wc -c 'xlisp.h'`"
then
echo shar: error transmitting "'xlisp.h'" '(should have been 9596 characters)'
fi
echo shar: extracting "'xlisp.bat'" '(99 characters)'
if test -f 'xlisp.bat'
then
echo shar: over-writing existing file "'xlisp.bat'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.bat'
Xrm B:XLISP.PRG
Xrm B:XLISP.TTP
Xlink68 [tem[b:],com[b:xlisp.inp]]
Xrelmod b:xlisp
Xrm B:XLISP.68K
Xwait
SHAR_EOF
if test 99 -ne "`wc -c 'xlisp.bat'`"
then
echo shar: error transmitting "'xlisp.bat'" '(should have been 99 characters)'
fi
echo shar: extracting "'xlisp.inp'" '(243 characters)'
if test -f 'xlisp.inp'
then
echo shar: over-writing existing file "'xlisp.inp'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.inp'
Xb:xlisp.68k=
Xgems,
Xb:xlbfun,b:xlcont,b:xldbug,b:xldmem,b:xleval,b:xlfio,b:xlftab1,b:xlftab2,
Xb:xlglob,b:xlinit,b:xlio,b:xlisp,b:xljump,b:xllist,b:xlmath,b:xlobj,
Xb:xlprin,b:xlread,b:xlstr,b:xlsubr,b:xlsym,b:xlsys,
Xb:ststuff,osbind,gemlib,libf
SHAR_EOF
if test 243 -ne "`wc -c 'xlisp.inp'`"
then
echo shar: error transmitting "'xlisp.inp'" '(should have been 243 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# ststuff.c
# xlbfun.c
# xlcont.c
# xldbug.c
# xldmem.c
# xleval.c
# xlfio.c
# xlftab1.c
# This archive created: Sat Jan 18 14:32:22 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'ststuff.c'" '(2963 characters)'
if test -f 'ststuff.c'
then
echo shar: over-writing existing file "'ststuff.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'ststuff.c'
X/* ststuff.c - atari 520st specific routines */
X
X#include <stdio.h>
X#include <osbind.h>
X
X#define LBSIZE 200
X
X/* line buffer variables */
Xstatic char lbuf[LBSIZE];
Xstatic int lpos[LBSIZE];
Xstatic int lindex = 0;
Xstatic int lcount = 0;
Xstatic int lposition = 0;
X
X/* external variables */
Xextern int prompt;
X
X/* external routines */
Xextern double sin(),cos();
X
X/* tan - tangent */
Xdouble tan(x)
X double x;
X{
X return (sin(x) / cos(x));
X}
X
X/* stcheck - check for a control key */
Xint stcheck()
X{
X return (xcheck());
X}
X
X/* stgetc - get a character from the terminal */
Xint stgetc(fp)
X FILE *fp;
X{
X int ch;
X
X /* check for input from a file other than stdin */
X if (fp != stdin)
X return (getc(fp));
X
X /* check for a buffered character */
X if (lcount--)
X return (lbuf[lindex++]);
X
X /* get an input line */
X for (lcount = 0; ; )
X switch (ch = xgetc()) {
X case '\r':
X stputc('\n',stdout);
X lbuf[lcount++] = '\n';
X lindex = 0; lcount--;
X return (lbuf[lindex++]);
X case '\010':
X case '\177':
X if (lcount) {
X lcount--;
X while (lposition && lposition > lpos[lcount]) {
X stputc('\010',stdout);
X stputc(' ',stdout);
X stputc('\010',stdout);
X }
X }
X break;
X default:
X
X /* check for normal printing characters */
X if (ch == '\t' || (ch >= ' ' && ch < '\177')) {
X lbuf[lcount] = ch;
X lpos[lcount] = lposition;
X stputc(ch,stdout);
X lcount++;
X }
X
X /* check for control codes */
X else {
X stflush();
X if (ch == '\003') /* control-c (exit) */
X exit();
X else if (ch == '\007') /* control-g (clean-up) */
X xlcleanup();
X else if (ch == '\020') /* control-p (continue) */
X xlcontinue();
X else if (ch == '\032') /* control-z (eof) */
X return (EOF);
X return (ch);
X }
X }
X}
X
X/* stputc - put a character to the terminal */
Xstputc(ch,fp)
X int ch; FILE *fp;
X{
X /* check for output to something other than stdout */
X if (fp != stdout)
X return (putc(ch,fp));
X
X /* check for newline */
X if (ch == '\n') {
X lposition = 0;
X xputc('\r');
X xputc('\n');
X }
X
X /* otherwise, check for tab */
X else if (ch == '\t') {
X do {
X stputc(' ',stdout);
X } while (lposition & 7);
X }
X
X /* otherwise, check for a backspace */
X else if (ch == '\010') {
X lposition--;
X xputc(ch);
X }
X
X /* otherwise, check for a printing character */
X else if (ch >= ' ' && ch < '\177') {
X xputc(ch);
X if (++lposition >= 80)
X stputc('\n',stdout);
X }
X
X /* otherwise, it must be a nonprinting character */
X else
X xputc(ch);
X}
X
X/* stflush - flush the input buffer */
Xstflush()
X{
X lcount = lindex = 0;
X stputc('\n',stdout);
X prompt = 1;
X}
X
X/* xgetc - get a character from the terminal without echo */
Xstatic int xgetc()
X{
X return (Crawcin() & 0xFF);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X int ch;
X{
X Crawio(ch);
X}
X
X/* xcheck - get a character if one is available */
Xstatic int xcheck()
X{
X return (Crawio(0xFF) & 0xFF);
X}
SHAR_EOF
if test 2963 -ne "`wc -c 'ststuff.c'`"
then
echo shar: error transmitting "'ststuff.c'" '(should have been 2963 characters)'
fi
echo shar: extracting "'xlbfun.c'" '(11528 characters)'
if test -f 'xlbfun.c'
then
echo shar: over-writing existing file "'xlbfun.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
X/* xlbfun.c - xlisp basic built-in functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *s_comma,*s_comat;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* forward declarations */
XFORWARD NODE *bquote1();
XFORWARD NODE *defun();
XFORWARD NODE *makesymbol();
X
X/* xeval - the built-in function 'eval' */
XNODE *xeval(args)
X NODE *args;
X{
X NODE *oldstk,expr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* get the expression to evaluate */
X expr.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* evaluate the expression */
X val = xleval(expr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xapply - the built-in function 'apply' */
XNODE *xapply(args)
X NODE *args;
X{
X NODE *oldstk,fun,arglist,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fun,&arglist,NULL);
X
X /* get the function and argument list */
X fun.n_ptr = xlarg(&args);
X arglist.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* if the function is a symbol, get its value */
X if (symbolp(fun.n_ptr))
X fun.n_ptr = xleval(fun.n_ptr);
X
X /* apply the function to the arguments */
X val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xfuncall - the built-in function 'funcall' */
XNODE *xfuncall(args)
X NODE *args;
X{
X NODE *oldstk,fun,arglist,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fun,&arglist,NULL);
X
X /* get the function and argument list */
X fun.n_ptr = xlarg(&args);
X arglist.n_ptr = args;
X
X /* if the function is a symbol, get its value */
X if (symbolp(fun.n_ptr))
X fun.n_ptr = xleval(fun.n_ptr);
X
X /* apply the function to the arguments */
X val = xlapply(fun.n_ptr,arglist.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression evaluated */
X return (val);
X}
X
X/* xquote - built-in function to quote an expression */
XNODE *xquote(args)
X NODE *args;
X{
X NODE *val;
X
X /* get the argument */
X val = xlarg(&args);
X xllastarg(args);
X
X /* return the quoted expression */
X return (val);
X}
X
X/* xfunction - built-in function to quote a function */
XNODE *xfunction(args)
X NODE *args;
X{
X NODE *val,*n;
X
X /* get the argument */
X val = xlarg(&args);
X xllastarg(args);
X
X /* create a closure for lambda expressions */
X if (consp(val) && car(val) == s_lambda) {
X n = newnode(LIST);
X rplaca(n,val);
X rplacd(n,xlenv);
X val = n;
X }
X
X /* otherwise, get the value of a symbol */
X else if (symbolp(val))
X val = xlgetvalue(val);
X
X /* otherwise, its an error */
X else
X xlerror("not a function",val);
X
X /* return the function */
X return (val);
X}
X
X/* xbquote - back quote function */
XNODE *xbquote(args)
X NODE *args;
X{
X NODE *oldstk,expr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* get the expression */
X expr.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* fill in the template */
X val = bquote1(expr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* bquote1 - back quote helper function */
XLOCAL NODE *bquote1(expr)
X NODE *expr;
X{
X NODE *oldstk,val,list,*last,*new;
X
X /* handle atoms */
X if (atom(expr))
X val.n_ptr = expr;
X
X /* handle (comma <expr>) */
X else if (car(expr) == s_comma) {
X if (atom(cdr(expr)))
X xlfail("bad comma expression");
X val.n_ptr = xleval(car(cdr(expr)));
X }
X
X /* handle ((comma-at <expr>) ... ) */
X else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X oldstk = xlsave(&list,&val,NULL);
X if (atom(cdr(car(expr))))
X xlfail("bad comma-at expression");
X list.n_ptr = xleval(car(cdr(car(expr))));
X for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X new = newnode(LIST);
X rplaca(new,car(list.n_ptr));
X if (last)
X rplacd(last,new);
X else
X val.n_ptr = new;
X last = new;
X }
X if (last)
X rplacd(last,bquote1(cdr(expr)));
X else
X val.n_ptr = bquote1(cdr(expr));
X xlstack = oldstk;
X }
X
X /* handle any other list */
X else {
X oldstk = xlsave(&val,NULL);
X val.n_ptr = newnode(LIST);
X rplaca(val.n_ptr,bquote1(car(expr)));
X rplacd(val.n_ptr,bquote1(cdr(expr)));
X xlstack = oldstk;
X }
X
X /* return the result */
X return (val.n_ptr);
X}
X
X/* xset - built-in function set */
XNODE *xset(args)
X NODE *args;
X{
X NODE *sym,*val;
X
X /* get the symbol and new value */
X sym = xlmatch(SYM,&args);
X val = xlarg(&args);
X xllastarg(args);
X
X /* assign the symbol the value of argument 2 and the return value */
X xlsetvalue(sym,val);
X
X /* return the result value */
X return (val);
X}
X
X/* xsetq - built-in function setq */
XNODE *xsetq(args)
X NODE *args;
X{
X NODE *oldstk,arg,sym,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* handle each pair of arguments */
X while (arg.n_ptr) {
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X val.n_ptr = xlevarg(&arg.n_ptr);
X xlsetvalue(sym.n_ptr,val.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val.n_ptr);
X}
X
X/* xsetf - built-in function 'setf' */
XNODE *xsetf(args)
X NODE *args;
X{
X NODE *oldstk,arg,place,value;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&place,&value,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* handle each pair of arguments */
X while (arg.n_ptr) {
X
X /* get place and value */
X place.n_ptr = xlarg(&arg.n_ptr);
X value.n_ptr = xlevarg(&arg.n_ptr);
X
X /* check the place form */
X if (symbolp(place.n_ptr))
X xlsetvalue(place.n_ptr,value.n_ptr);
X else if (consp(place.n_ptr))
X placeform(place.n_ptr,value.n_ptr);
X else
X xlfail("bad place form");
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (value.n_ptr);
X}
X
X/* placeform - handle a place form other than a symbol */
XLOCAL placeform(place,value)
X NODE *place,*value;
X{
X NODE *fun,*oldstk,arg1,arg2;
X
X /* check the function name */
X if ((fun = xlmatch(SYM,&place)) == s_get) {
X oldstk = xlsave(&arg1,&arg2,NULL);
X arg1.n_ptr = xlevmatch(SYM,&place);
X arg2.n_ptr = xlevmatch(SYM,&place);
X xllastarg(place);
X xlputprop(arg1.n_ptr,value,arg2.n_ptr);
X xlstack = oldstk;
X }
X else if (fun == s_svalue || fun == s_splist) {
X oldstk = xlsave(&arg1,NULL);
X arg1.n_ptr = xlevmatch(SYM,&place);
X xllastarg(place);
X if (fun == s_svalue)
X setvalue(arg1.n_ptr,value);
X else
X rplacd(arg1.n_ptr->n_symplist,value);
X xlstack = oldstk;
X }
X else if (fun == s_car || fun == s_cdr) {
X oldstk = xlsave(&arg1,NULL);
X arg1.n_ptr = xlevmatch(LIST,&place);
X xllastarg(place);
X if (consp(arg1.n_ptr))
X if (fun == s_car)
X rplaca(arg1.n_ptr,value);
X else
X rplacd(arg1.n_ptr,value);
X xlstack = oldstk;
X }
X else
X xlfail("bad place form");
X}
X
X/* xdefun - built-in function 'defun' */
XNODE *xdefun(args)
X NODE *args;
X{
X return (defun(args,s_lambda));
X}
X
X/* xdefmacro - built-in function 'defmacro' */
XNODE *xdefmacro(args)
X NODE *args;
X{
X return (defun(args,s_macro));
X}
X
X/* defun - internal function definition routine */
XLOCAL NODE *defun(args,type)
X NODE *args,*type;
X{
X NODE *oldstk,sym,fargs,closure,*fun;
X
X /* create a new stack frame */
X oldstk = xlsave(&sym,&fargs,&closure,NULL);
X
X /* get the function symbol and formal argument list */
X sym.n_ptr = xlmatch(SYM,&args);
X fargs.n_ptr = xlmatch(LIST,&args);
X
X /* create a new function definition */
X closure.n_ptr = newnode(LIST);
X rplaca(closure.n_ptr,fun = newnode(LIST));
X rplacd(closure.n_ptr,xlenv);
X rplaca(fun,type);
X rplacd(fun,newnode(LIST));
X rplaca(cdr(fun),fargs.n_ptr);
X rplacd(cdr(fun),args);
X
X /* make the symbol point to a new function definition */
X xlsetvalue(sym.n_ptr,closure.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the function symbol */
X return (sym.n_ptr);
X}
X
X/* xgensym - generate a symbol */
XNODE *xgensym(args)
X NODE *args;
X{
X char sym[STRMAX+1];
X NODE *x;
X
X /* get the prefix or number */
X if (args) {
X x = xlarg(&args);
X switch (ntype(x)) {
X case STR:
X strcpy(gsprefix,x->n_str);
X break;
X case INT:
X gsnumber = x->n_int;
X break;
X default:
X xlerror("bad argument type",x);
X }
X }
X xllastarg(args);
X
X /* create the pname of the new symbol */
X sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X /* make a symbol with this print name */
X return (xlmakesym(sym,DYNAMIC));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XNODE *xmakesymbol(args)
X NODE *args;
X{
X return (makesymbol(args,FALSE));
X}
X
X/* xintern - make a new interned symbol */
XNODE *xintern(args)
X NODE *args;
X{
X return (makesymbol(args,TRUE));
X}
X
X/* makesymbol - make a new symbol */
XLOCAL NODE *makesymbol(args,iflag)
X NODE *args; int iflag;
X{
X NODE *oldstk,pname,*val;
X char *str;
X
X /* create a new stack frame */
X oldstk = xlsave(&pname,NULL);
X
X /* get the print name of the symbol to intern */
X pname.n_ptr = xlmatch(STR,&args);
X xllastarg(args);
X
X /* make the symbol */
X str = pname.n_ptr->n_str;
X val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the symbol */
X return (val);
X}
X
X/* xsymname - get the print name of a symbol */
XNODE *xsymname(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return the print name */
X return (car(sym->n_symplist));
X}
X
X/* xsymvalue - get the value of a symbol */
XNODE *xsymvalue(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return its value */
X return (xlgetvalue(sym));
X}
X
X/* xsymplist - get the property list of a symbol */
XNODE *xsymplist(args)
X NODE *args;
X{
X NODE *sym;
X
X /* get the symbol */
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* return the property list */
X return (cdr(sym->n_symplist));
X}
X
X/* xget - get the value of a property */
XNODE *xget(args)
X NODE *args;
X{
X NODE *sym,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* retrieve the property value */
X return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XNODE *xputprop(args)
X NODE *args;
X{
X NODE *sym,*val,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X val = xlarg(&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* set the property value */
X xlputprop(sym,val,prp);
X
X /* return the value */
X return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XNODE *xremprop(args)
X NODE *args;
X{
X NODE *sym,*prp;
X
X /* get the symbol and property */
X sym = xlmatch(SYM,&args);
X prp = xlmatch(SYM,&args);
X xllastarg(args);
X
X /* remove the property */
X xlremprop(sym,prp);
X
X /* return nil */
X return (NIL);
X}
SHAR_EOF
if test 11528 -ne "`wc -c 'xlbfun.c'`"
then
echo shar: error transmitting "'xlbfun.c'" '(should have been 11528 characters)'
fi
echo shar: extracting "'xlcont.c'" '(17682 characters)'
if test -f 'xlcont.c'
then
echo shar: over-writing existing file "'xlcont.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
X/* xlcont - xlisp control built-in functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv,*xlvalue;
Xextern NODE *s_unbound;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *true;
X
X/* external routines */
Xextern NODE *xlxeval();
X
X/* forward declarations */
XFORWARD NODE *let();
XFORWARD NODE *prog();
XFORWARD NODE *progx();
XFORWARD NODE *doloop();
X
X/* xcond - built-in function 'cond' */
XNODE *xcond(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* initialize the return value */
X val = NIL;
X
X /* find a predicate that is true */
X while (arg.n_ptr) {
X
X /* get the next conditional */
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* evaluate the predicate part */
X if (xlevarg(&list.n_ptr)) {
X
X /* evaluate each expression */
X while (list.n_ptr)
X val = xlevarg(&list.n_ptr);
X
X /* exit the loop */
X break;
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (val);
X}
X
X/* xand - built-in function 'and' */
XNODE *xand(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X val = true;
X
X /* evaluate each argument */
X while (arg.n_ptr)
X
X /* get the next argument */
X if ((val = xlevarg(&arg.n_ptr)) == NIL)
X break;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xor - built-in function 'or' */
XNODE *xor(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X val = NIL;
X
X /* evaluate each argument */
X while (arg.n_ptr)
X if ((val = xlevarg(&arg.n_ptr)))
X break;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xif - built-in function 'if' */
XNODE *xif(args)
X NODE *args;
X{
X NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
X
X /* get the test expression, then clause and else clause */
X testexpr.n_ptr = xlarg(&args);
X thenexpr.n_ptr = xlarg(&args);
X elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* evaluate the appropriate clause */
X val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last value */
X return (val);
X}
X
X/* xlet - built-in function 'let' */
XNODE *xlet(args)
X NODE *args;
X{
X return (let(args,TRUE));
X}
X
X/* xletstar - built-in function 'let*' */
XNODE *xletstar(args)
X NODE *args;
X{
X return (let(args,FALSE));
X}
X
X/* let - common let routine */
XLOCAL NODE *let(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* execute the code */
X for (val = NIL; arg.n_ptr; )
X val = xlevarg(&arg.n_ptr);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xprog - built-in function 'prog' */
XNODE *xprog(args)
X NODE *args;
X{
X return (prog(args,TRUE));
X}
X
X/* xprogstar - built-in function 'prog*' */
XNODE *xprogstar(args)
X NODE *args;
X{
X return (prog(args,FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL NODE *prog(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(xlmatch(LIST,&arg.n_ptr),newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* execute the code */
X tagblock(arg.n_ptr,&val);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xgo - built-in function 'go' */
XNODE *xgo(args)
X NODE *args;
X{
X NODE *label;
X
X /* get the target label */
X label = xlarg(&args);
X xllastarg(args);
X
X /* transfer to the label */
X xlgo(label);
X}
X
X/* xreturn - built-in function 'return' */
XNODE *xreturn(args)
X NODE *args;
X{
X NODE *val;
X
X /* get the return value */
X val = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* return from the inner most block */
X xlreturn(val);
X}
X
X/* xprog1 - built-in function 'prog1' */
XNODE *xprog1(args)
X NODE *args;
X{
X return (progx(args,1));
X}
X
X/* xprog2 - built-in function 'prog2' */
XNODE *xprog2(args)
X NODE *args;
X{
X return (progx(args,2));
X}
X
X/* progx - common progx code */
XLOCAL NODE *progx(args,n)
X NODE *args; int n;
X{
X NODE *oldstk,arg,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate the first n expressions */
X while (n--)
X val.n_ptr = xlevarg(&arg.n_ptr);
X
X /* evaluate each remaining argument */
X while (arg.n_ptr)
X xlevarg(&arg.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val.n_ptr);
X}
X
X/* xprogn - built-in function 'progn' */
XNODE *xprogn(args)
X NODE *args;
X{
X NODE *oldstk,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate each remaining argument */
X for (val = NIL; arg.n_ptr; )
X val = xlevarg(&arg.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xdo - built-in function 'do' */
XNODE *xdo(args)
X NODE *args;
X{
X return (doloop(args,TRUE));
X}
X
X/* xdostar - built-in function 'do*' */
XNODE *xdostar(args)
X NODE *args;
X{
X return (doloop(args,FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL NODE *doloop(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,newenv,arg,blist,clist,test,*rval;
X int rbreak;
X
X /* create a new stack frame */
X oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the list of bindings */
X blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(xlenv);
X
X /* bind the symbols */
X if (!pflag) xlenv = newenv.n_ptr;
X dobindings(blist.n_ptr,newenv.n_ptr);
X if (pflag) xlenv = newenv.n_ptr;
X
X /* get the exit test and result forms */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X test.n_ptr = xlarg(&clist.n_ptr);
X
X /* execute the loop as long as the test is false */
X rbreak = FALSE;
X while (xleval(test.n_ptr) == NIL) {
X
X /* execute the body of the loop */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X
X /* update the looping variables */
X doupdates(blist.n_ptr,pflag);
X }
X
X /* evaluate the result expression */
X if (!rbreak)
X for (rval = NIL; consp(clist.n_ptr); )
X rval = xlevarg(&clist.n_ptr);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xdolist - built-in function 'dolist' */
XNODE *xdolist(args)
X NODE *args;
X{
X NODE *oldstk,arg,clist,sym,list,val,*rval;
X int rbreak;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the control list (sym list result-expr) */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
X val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym.n_ptr,NIL,xlenv);
X
X /* loop through the list */
X rbreak = FALSE;
X for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym.n_ptr,car(list.n_ptr));
X
X /* execute the loop body */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X }
X
X /* evaluate the result expression */
X if (!rbreak) {
X xlsetvalue(sym.n_ptr,NIL);
X rval = xleval(val.n_ptr);
X }
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xdotimes - built-in function 'dotimes' */
XNODE *xdotimes(args)
X NODE *args;
X{
X NODE *oldstk,arg,clist,sym,val,*rval;
X int rbreak,cnt,i;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the control list (sym list result-expr) */
X clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
X sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
X cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
X val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym.n_ptr,NIL,xlenv);
X
X /* loop through for each value from zero to cnt-1 */
X rbreak = FALSE;
X for (i = 0; i < cnt; i++) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)i));
X
X /* execute the loop body */
X if (tagblock(arg.n_ptr,&rval)) {
X rbreak = TRUE;
X break;
X }
X }
X
X /* evaluate the result expression */
X if (!rbreak) {
X xlsetvalue(sym.n_ptr,cvfixnum((FIXNUM)cnt));
X rval = xleval(val.n_ptr);
X }
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (rval);
X}
X
X/* xcatch - built-in function 'catch' */
XNODE *xcatch(args)
X NODE *args;
X{
X NODE *oldstk,tag,arg,*val;
X CONTEXT cntxt;
X
X /* create a new stack frame */
X oldstk = xlsave(&tag,&arg,NULL);
X
X /* initialize */
X tag.n_ptr = xlevarg(&args);
X arg.n_ptr = args;
X val = NIL;
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_THROW,tag.n_ptr);
X
X /* check for 'throw' */
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X
X /* otherwise, evaluate the remainder of the arguments */
X else {
X while (arg.n_ptr)
X val = xlevarg(&arg.n_ptr);
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xthrow - built-in function 'throw' */
XNODE *xthrow(args)
X NODE *args;
X{
X NODE *tag,*val;
X
X /* get the tag and value */
X tag = xlarg(&args);
X val = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* throw the tag */
X xlthrow(tag,val);
X}
X
X/* xerror - built-in function 'error' */
XNODE *xerror(args)
X NODE *args;
X{
X char *emsg; NODE *arg;
X
X /* get the error message and the argument */
X emsg = xlmatch(STR,&args)->n_str;
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* signal the error */
X xlerror(emsg,arg);
X}
X
X/* xcerror - built-in function 'cerror' */
XNODE *xcerror(args)
X NODE *args;
X{
X char *cmsg,*emsg; NODE *arg;
X
X /* get the correction message, the error message, and the argument */
X cmsg = xlmatch(STR,&args)->n_str;
X emsg = xlmatch(STR,&args)->n_str;
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* signal the error */
X xlcerror(cmsg,emsg,arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xbreak - built-in function 'break' */
XNODE *xbreak(args)
X NODE *args;
X{
X char *emsg; NODE *arg;
X
X /* get the error message */
X emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
X arg = (args ? xlarg(&args) : s_unbound);
X xllastarg(args);
X
X /* enter the break loop */
X xlbreak(emsg,arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xcleanup - built-in function 'clean-up' */
XNODE *xcleanup(args)
X NODE *args;
X{
X xllastarg(args);
X xlcleanup();
X}
X
X/* xcontinue - built-in function 'continue' */
XNODE *xcontinue(args)
X NODE *args;
X{
X xllastarg(args);
X xlcontinue();
X}
X
X/* xerrset - built-in function 'errset' */
XNODE *xerrset(args)
X NODE *args;
X{
X NODE *oldstk,expr,flag,*val;
X CONTEXT cntxt;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,&flag,NULL);
X
X /* get the expression and the print flag */
X expr.n_ptr = xlarg(&args);
X flag.n_ptr = (args ? xlarg(&args) : true);
X xllastarg(args);
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
X
X /* check for error */
X if (setjmp(cntxt.c_jmpbuf))
X val = NIL;
X
X /* otherwise, evaluate the expression */
X else {
X expr.n_ptr = xleval(expr.n_ptr);
X val = newnode(LIST);
X rplaca(val,expr.n_ptr);
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xevalhook - eval hook function */
XNODE *xevalhook(args)
X NODE *args;
X{
X NODE *oldstk,expr,ehook,ahook,env,newehook,newahook,newenv,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,NULL);
X
X /* get the expression, the new hook functions and the environment */
X expr.n_ptr = xlarg(&args);
X newehook.n_ptr = xlarg(&args);
X newahook.n_ptr = xlarg(&args);
X newenv.n_ptr = (args ? xlarg(&args) : xlenv);
X xllastarg(args);
X
X /* bind *evalhook* and *applyhook* to the hook functions */
X ehook.n_ptr = getvalue(s_evalhook);
X setvalue(s_evalhook,newehook.n_ptr);
X ahook.n_ptr = getvalue(s_applyhook);
X setvalue(s_applyhook,newahook.n_ptr);
X env.n_ptr = xlenv;
X xlenv = newenv.n_ptr;
X
X /* evaluate the expression (bypassing *evalhook*) */
X val = xlxeval(expr.n_ptr);
X
X /* unbind the hook variables */
X setvalue(s_evalhook,ehook.n_ptr);
X setvalue(s_applyhook,ahook.n_ptr);
X xlenv = env.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(blist,env)
X NODE *blist,*env;
X{
X NODE *oldstk,list,bnd,sym,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
X
X /* bind each symbol in the list of bindings */
X for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* get the next binding */
X bnd.n_ptr = car(list.n_ptr);
X
X /* handle a symbol */
X if (symbolp(bnd.n_ptr)) {
X sym.n_ptr = bnd.n_ptr;
X val.n_ptr = NIL;
X }
X
X /* handle a list of the form (symbol expr) */
X else if (consp(bnd.n_ptr)) {
X sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X val.n_ptr = xlevarg(&bnd.n_ptr);
X }
X else
X xlfail("bad binding");
X
X /* bind the value to the symbol */
X xlbind(sym.n_ptr,val.n_ptr,env);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X}
X
X/* doupdates - handle updates for do/do* */
Xdoupdates(blist,pflag)
X NODE *blist; int pflag;
X{
X NODE *oldstk,plist,list,bnd,sym,val,*p;
X
X /* create a new stack frame */
X oldstk = xlsave(&plist,&list,&bnd,&sym,&val,NULL);
X
X /* bind each symbol in the list of bindings */
X for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
X
X /* get the next binding */
X bnd.n_ptr = car(list.n_ptr);
X
X /* handle a list of the form (symbol expr) */
X if (consp(bnd.n_ptr)) {
X sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
X bnd.n_ptr = cdr(bnd.n_ptr);
X if (bnd.n_ptr) {
X val.n_ptr = xlevarg(&bnd.n_ptr);
X if (pflag) {
X p = newnode(LIST);
X rplacd(p,plist.n_ptr);
X plist.n_ptr = p;
X rplaca(p,newnode(LIST));
X rplaca(car(p),sym.n_ptr);
X rplacd(car(p),val.n_ptr);
X }
X else
X xlsetvalue(sym.n_ptr,val.n_ptr);
X }
X }
X }
X
X /* set the values for parallel updates */
X for (; plist.n_ptr; plist.n_ptr = cdr(plist.n_ptr))
X xlsetvalue(car(car(plist.n_ptr)),cdr(car(plist.n_ptr)));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X}
X
X/* tagblock - execute code within a block and tagbody */
Xint tagblock(code,pval)
X NODE *code,**pval;
X{
X NODE *oldstk,arg;
X CONTEXT cntxt;
X int type,sts;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,NULL);
X
X /* initialize */
X arg.n_ptr = code;
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
X
X /* check for a 'return' */
X if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
X *pval = xlvalue;
X sts = TRUE;
X }
X
X /* otherwise, enter the body */
X else {
X
X /* check for a 'go' */
X if (type == CF_GO)
X arg.n_ptr = xlvalue;
X
X /* evaluate each expression in the body */
X while (consp(arg.n_ptr))
X if (consp(car(arg.n_ptr)))
X xlevarg(&arg.n_ptr);
X else
X arg.n_ptr = cdr(arg.n_ptr);
X
X /* fell out the bottom of the loop */
X *pval = NIL;
X sts = FALSE;
X }
X xlend(&cntxt);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return status */
X return (sts);
X}
SHAR_EOF
if test 17682 -ne "`wc -c 'xlcont.c'`"
then
echo shar: error transmitting "'xlcont.c'" '(should have been 17682 characters)'
fi
echo shar: extracting "'xldbug.c'" '(4177 characters)'
if test -f 'xldbug.c'
then
echo shar: over-writing existing file "'xldbug.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
X/* xldebug - xlisp debugging support */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern long total;
Xextern int xldebug;
Xextern int xltrace;
Xextern NODE *s_unbound;
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
Xextern NODE *xlstack;
Xextern NODE *true;
Xextern NODE **trace_stack;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD NODE *stacktop();
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X char *emsg;
X{
X xlerror(emsg,stacktop());
X}
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X char *emsg;
X{
X xlsignal(emsg,s_unbound);
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X char *emsg; NODE *arg;
X{
X breakloop("break",NULL,emsg,arg,TRUE);
X}
X
X/* xlerror - handle a fatal error */
Xxlerror(emsg,arg)
X char *emsg; NODE *arg;
X{
X doerror(NULL,emsg,arg,FALSE);
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X char *cmsg,*emsg; NODE *arg;
X{
X doerror(cmsg,emsg,arg,TRUE);
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X char *hdr,*cmsg,*emsg; NODE *arg;
X{
X sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
X if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
X else xlterpri(s_stdout->n_symvalue);
X if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
X}
X
X/* doerror - handle xlisp errors */
XLOCAL doerror(cmsg,emsg,arg,cflag)
X char *cmsg,*emsg; NODE *arg; int cflag;
X{
X /* make sure the break loop is enabled */
X if (getvalue(s_breakenable) == NIL)
X xlsignal(emsg,arg);
X
X /* call the debug read-eval-print loop */
X breakloop("error",cmsg,emsg,arg,cflag);
X}
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
X{
X NODE *oldstk,expr,*val;
X CONTEXT cntxt;
X int type;
X
X /* print the error message */
X xlerrprint(hdr,cmsg,emsg,arg);
X
X /* flush the input buffer */
X xlflush();
X
X /* do the back trace */
X if (getvalue(s_tracenable)) {
X val = getvalue(s_tlimit);
X xlbaktrace(fixp(val) ? (int)val->n_int : -1);
X }
X
X /* create a new stack frame */
X oldstk = xlsave(&expr,NULL);
X
X /* increment the debug level */
X xldebug++;
X
X /* debug command processing loop */
X xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
X for (type = 0; type == 0; ) {
X
X /* setup the continue trap */
X if (type = setjmp(cntxt.c_jmpbuf))
X switch (type) {
X case CF_ERROR:
X xlflush();
X type = 0;
X continue;
X case CF_CLEANUP:
X continue;
X case CF_CONTINUE:
X if (cflag) continue;
X else xlabort("this error can't be continued");
X }
X
X /* read an expression and check for eof */
X if (!xlread(getvalue(s_stdin),&expr.n_ptr)) {
X type = CF_CLEANUP;
X break;
X }
X
X /* evaluate the expression */
X expr.n_ptr = xleval(expr.n_ptr);
X
X /* print it */
X xlprint(getvalue(s_stdout),expr.n_ptr,TRUE);
X xlterpri(getvalue(s_stdout));
X }
X xlend(&cntxt);
X
X /* decrement the debug level */
X xldebug--;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* continue the next higher break loop on clean-up */
X if (type == CF_CLEANUP)
X xlsignal("quit from break loop",s_unbound);
X}
X
X/* tpush - add an entry to the trace stack */
Xxltpush(nptr)
X NODE *nptr;
X{
X if (++xltrace < TDEPTH)
X trace_stack[xltrace] = nptr;
X}
X
X/* tpop - pop an entry from the trace stack */
Xxltpop()
X{
X xltrace--;
X}
X
X/* stacktop - return the top node on the stack */
XLOCAL NODE *stacktop()
X{
X return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
X}
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X int n;
X{
X int i;
X
X for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
X if (i < TDEPTH)
X stdprint(trace_stack[i]);
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
X xlabort("insufficient memory");
X total += (long) TSTKSIZE;
X xltrace = -1;
X xldebug = 0;
X}
SHAR_EOF
if test 4177 -ne "`wc -c 'xldbug.c'`"
then
echo shar: error transmitting "'xldbug.c'" '(should have been 4177 characters)'
fi
echo shar: extracting "'xldmem.c'" '(7170 characters)'
if test -f 'xldmem.c'
then
echo shar: over-writing existing file "'xldmem.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
X/* xldmem - xlisp dynamic memory management routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* useful definitions */
X#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
X
X/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
Xextern long total;
Xextern int anodes,nnodes,nsegs,nfree,gccalls;
Xextern struct segment *segs;
Xextern NODE *fnodes;
Xextern char buf[];
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* newnode - allocate a new node */
XNODE *newnode(type)
X int type;
X{
X NODE *nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X gc();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X nfree -= 1;
X
X /* initialize the new node */
X nnode->n_type = type;
X rplacd(nnode,NIL);
X
X /* return the new node */
X return (nnode);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XNODE *cvfixnum(n)
X FIXNUM n;
X{
X NODE *val;
X val = newnode(INT);
X val->n_int = n;
X return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XNODE *cvflonum(n)
X FLONUM n;
X{
X NODE *val;
X val = newnode(FLOAT);
X val->n_float = n;
X return (val);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
Xchar *stralloc(size)
X int size;
X{
X char *sptr;
X
X /* allocate memory for the string copy */
X if ((sptr = malloc(size+1)) == NULL) {
X gc();
X if ((sptr = malloc(size+1)) == NULL)
X xlfail("insufficient string space");
X }
X total += (long) (size+1);
X
X /* return the new string memory */
X return (sptr);
X}
X
X/* strsave - generate a dynamic copy of a string */
Xchar *strsave(str)
X char *str;
X{
X char *sptr;
X
X /* create a new string */
X sptr = stralloc(strlen(str));
X strcpy(sptr,str);
X
X /* return the new string */
X return (sptr);
X}
X
X/* strfree - free string memory */
Xstrfree(str)
X char *str;
X{
X total -= (long) (strlen(str)+1);
X free(str);
X}
X
X/* gc - garbage collect */
Xgc()
X{
X NODE *p;
X
X /* mark all accessible nodes */
X mark(oblist); mark(keylist);
X mark(xlenv);
X
X /* mark the evaluation stack */
X for (p = xlstack; p; p = cdr(p))
X mark(car(p));
X
X /* sweep memory collecting all unmarked nodes */
X sweep();
X
X /* if there's still nothing available, allocate more memory */
X if (fnodes == NIL)
X addseg();
X
X /* count the gc call */
X gccalls++;
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X NODE *ptr;
X{
X NODE *this,*prev,*tmp;
X
X /* just return on nil */
X if (ptr == NIL)
X return;
X
X /* initialize */
X prev = NIL;
X this = ptr;
X
X /* mark this list */
X while (TRUE) {
X
X /* descend as far as we can */
X while (TRUE) {
X
X /* check for this node being marked */
X if (this->n_flags & MARK)
X break;
X
X /* mark it and its descendants */
X else {
X
X /* mark the node */
X this->n_flags |= MARK;
X
X /* follow the left sublist if there is one */
X if (livecar(this)) {
X this->n_flags |= LEFT;
X tmp = prev;
X prev = this;
X this = car(prev);
X rplaca(prev,tmp);
X }
X
X /* otherwise, follow the right sublist if there is one */
X else if (livecdr(this)) {
X this->n_flags &= ~LEFT;
X tmp = prev;
X prev = this;
X this = cdr(prev);
X rplacd(prev,tmp);
X }
X else
X break;
X }
X }
X
X /* backup to a point where we can continue descending */
X while (TRUE) {
X
X /* check for termination condition */
X if (prev == NIL)
X return;
X
X /* check for coming from the left side */
X if (prev->n_flags & LEFT)
X if (livecdr(prev)) {
X prev->n_flags &= ~LEFT;
X tmp = car(prev);
X rplaca(prev,this);
X this = cdr(prev);
X rplacd(prev,tmp);
X break;
X }
X else {
X tmp = prev;
X prev = car(tmp);
X rplaca(tmp,this);
X this = tmp;
X }
X
X /* otherwise, came from the right side */
X else {
X tmp = prev;
X prev = cdr(tmp);
X rplacd(tmp,this);
X this = tmp;
X }
X }
X }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X struct segment *seg;
X NODE *p;
X int n;
X
X /* empty the free list */
X fnodes = NIL;
X nfree = 0;
X
X /* add all unmarked nodes */
X for (seg = segs; seg != NULL; seg = seg->sg_next) {
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; n--; p++)
X if (!(p->n_flags & MARK)) {
X switch (ntype(p)) {
X case STR:
X if (p->n_strtype == DYNAMIC && p->n_str != NULL)
X strfree(p->n_str);
X break;
X case FPTR:
X if (p->n_fp)
X fclose(p->n_fp);
X break;
X }
X p->n_type = FREE;
X p->n_flags = 0;
X rplaca(p,NIL);
X rplacd(p,fnodes);
X fnodes = p;
X nfree++;
X }
X else
X p->n_flags &= ~(MARK | LEFT);
X }
X}
X
X/* addseg - add a segment to the available memory */
Xint addseg()
X{
X struct segment *newseg;
X NODE *p;
X int n;
X
X /* check for zero allocation */
X if (anodes == 0)
X return (FALSE);
X
X /* allocate a new segment */
X if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
X
X /* initialize the new segment */
X newseg->sg_size = anodes;
X newseg->sg_next = segs;
X segs = newseg;
X
X /* add each new node to the free list */
X p = &newseg->sg_nodes[0];
X for (n = anodes; n--; ) {
X rplacd(p,fnodes);
X fnodes = p++;
X }
X
X /* update the statistics */
X total += (long) ALLOCSIZE;
X nnodes += anodes;
X nfree += anodes;
X nsegs++;
X
X /* return successfully */
X return (TRUE);
X }
X else
X return (FALSE);
X}
X
X/* livecar - do we need to follow the car? */
XLOCAL int livecar(n)
X NODE *n;
X{
X switch (ntype(n)) {
X case SUBR:
X case FSUBR:
X case INT:
X case FLOAT:
X case STR:
X case FPTR:
X return (FALSE);
X case SYM:
X case LIST:
X case OBJ:
X return (car(n) != NIL);
X default:
X printf("bad node type (%d) found during left scan\n",ntype(n));
X exit();
X }
X}
X
X/* livecdr - do we need to follow the cdr? */
XLOCAL int livecdr(n)
X NODE *n;
X{
X switch (ntype(n)) {
X case SUBR:
X case FSUBR:
X case INT:
X case FLOAT:
X case STR:
X case FPTR:
X return (FALSE);
X case SYM:
X case LIST:
X case OBJ:
X return (cdr(n) != NIL);
X default:
X printf("bad node type (%d) found during right scan\n",ntype(n));
X exit();
X }
X}
X
X/* stats - print memory statistics */
Xstats()
X{
X sprintf(buf,"Nodes: %d\n",nnodes); stdputstr(buf);
X sprintf(buf,"Free nodes: %d\n",nfree); stdputstr(buf);
X sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
X sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
X sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
X sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X /* initialize our internal variables */
X anodes = NNODES;
X total = 0L;
X nnodes = nsegs = nfree = gccalls = 0;
X fnodes = NIL;
X segs = NULL;
X
X /* initialize structures that are marked by the collector */
X xlstack = xlenv = oblist = keylist = NIL;
X}
SHAR_EOF
if test 7170 -ne "`wc -c 'xldmem.c'`"
then
echo shar: error transmitting "'xldmem.c'" '(should have been 7170 characters)'
fi
echo shar: extracting "'xleval.c'" '(7937 characters)'
if test -f 'xleval.c'
then
echo shar: over-writing existing file "'xleval.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xleval.c'
X/* xleval - xlisp evaluator */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *k_optional,*k_rest,*k_aux;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *s_unbound;
Xextern NODE *s_stdout;
X
X/* forward declarations */
XFORWARD NODE *xlxeval();
XFORWARD NODE *evalhook();
XFORWARD NODE *evform();
XFORWARD NODE *evfun();
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XNODE *xleval(expr)
X NODE *expr;
X{
X return (getvalue(s_evalhook) ? evalhook(expr) : xlxeval(expr));
X}
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XNODE *xlxeval(expr)
X NODE *expr;
X{
X#ifdef MEGAMAX
X macidle();
X#endif
X
X /* evaluate nil to itself */
X if (expr == NIL)
X return (NIL);
X
X /* add trace entry */
X xltpush(expr);
X
X /* check type of value */
X if (consp(expr))
X expr = evform(expr);
X else if (symbolp(expr))
X expr = xlgetvalue(expr);
X
X /* remove trace entry */
X xltpop();
X
X /* return the value */
X return (expr);
X}
X
X/* xlapply - apply a function to a list of arguments */
XNODE *xlapply(fun,args)
X NODE *fun,*args;
X{
X NODE *env,*val;
X
X /* check for a null function */
X if (fun == NIL)
X xlfail("bad function");
X
X /* evaluate the function */
X if (subrp(fun))
X val = (*fun->n_subr)(args);
X else if (consp(fun)) {
X if (consp(car(fun))) {
X env = cdr(fun);
X fun = car(fun);
X }
X else
X env = xlenv;
X if (car(fun) != s_lambda)
X xlfail("bad function type");
X val = evfun(fun,args,env);
X }
X else
X xlfail("bad function");
X
X /* return the result value */
X return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL NODE *evform(expr)
X NODE *expr;
X{
X NODE *oldstk,fun,args,*env,*val,*type;
X
X /* create a stack frame */
X oldstk = xlsave(&fun,&args,NULL);
X
X /* get the function and the argument list */
X fun.n_ptr = car(expr);
X args.n_ptr = cdr(expr);
X
X /* evaluate the first expression */
X if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
X xlfail("bad function");
X
X /* evaluate the function */
X if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
X if (subrp(fun.n_ptr))
X args.n_ptr = xlevlist(args.n_ptr);
X val = (*fun.n_ptr->n_subr)(args.n_ptr);
X }
X else if (consp(fun.n_ptr)) {
X if (consp(car(fun.n_ptr))) {
X env = cdr(fun.n_ptr);
X fun.n_ptr = car(fun.n_ptr);
X }
X else
X env = xlenv;
X if ((type = car(fun.n_ptr)) == s_lambda) {
X args.n_ptr = xlevlist(args.n_ptr);
X val = evfun(fun.n_ptr,args.n_ptr,env);
X }
X else if (type == s_macro) {
X args.n_ptr = evfun(fun.n_ptr,args.n_ptr,env);
X val = xleval(args.n_ptr);
X }
X else
X xlfail("bad function type");
X }
X else if (objectp(fun.n_ptr))
X val = xlsend(fun.n_ptr,args.n_ptr);
X else
X xlfail("bad function");
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL NODE *evalhook(expr)
X NODE *expr;
X{
X NODE *oldstk,ehook,ahook,args,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&ehook,&ahook,&args,NULL);
X
X /* make an argument list */
X args.n_ptr = newnode(LIST);
X rplaca(args.n_ptr,expr);
X rplacd(args.n_ptr,newnode(LIST));
X rplaca(cdr(args.n_ptr),xlenv);
X
X /* rebind the hook functions to nil */
X ehook.n_ptr = getvalue(s_evalhook);
X setvalue(s_evalhook,NIL);
X ahook.n_ptr = getvalue(s_applyhook);
X setvalue(s_applyhook,NIL);
X
X /* call the hook function */
X val = xlapply(ehook.n_ptr,args.n_ptr);
X
X /* unbind the symbols */
X setvalue(s_evalhook,ehook.n_ptr);
X setvalue(s_applyhook,ahook.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the value */
X return (val);
X}
X
X/* xlevlist - evaluate a list of arguments */
XNODE *xlevlist(args)
X NODE *args;
X{
X NODE *oldstk,src,dst,*new,*last,*val;
X
X /* create a stack frame */
X oldstk = xlsave(&src,&dst,NULL);
X
X /* initialize */
X src.n_ptr = args;
X
X /* evaluate each argument */
X for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
X
X /* check this entry */
X if (!consp(src.n_ptr))
X xlfail("bad argument list");
X
X /* allocate a new list entry */
X new = newnode(LIST);
X if (val)
X rplacd(last,new);
X else
X val = dst.n_ptr = new;
X rplaca(new,xleval(car(src.n_ptr)));
X last = new;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new list */
X return (val);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X NODE *sym;
X{
X xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* evfun - evaluate a function */
XLOCAL NODE *evfun(fun,args,env)
X NODE *fun,*args,*env;
X{
X NODE *oldstk,oldenv,newenv,cptr,*fargs,*val;
X
X /* create a stack frame */
X oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
X
X /* skip the function type */
X if ((fun = cdr(fun)) == NIL || !consp(fun))
X xlfail("bad function definition");
X
X /* get the formal argument list */
X if ((fargs = car(fun)) && !consp(fargs))
X xlfail("bad formal argument list");
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(env);
X oldenv.n_ptr = xlenv;
X
X /* bind the formal parameters */
X xlabind(fargs,args,newenv.n_ptr);
X xlenv = newenv.n_ptr;
X
X /* execute the code */
X for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
X val = xlevarg(&cptr.n_ptr);
X
X /* restore the environment */
X xlenv = oldenv.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fargs,aargs,env)
X NODE *fargs,*aargs,*env;
X{
X NODE *arg;
X
X /* evaluate and bind each required argument */
X while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X /* bind the formal variable to the argument value */
X xlbind(arg,car(aargs),env);
X
X /* move the argument list pointers ahead */
X fargs = cdr(fargs);
X aargs = cdr(aargs);
X }
X
X /* check for the '&optional' keyword */
X if (consp(fargs) && car(fargs) == k_optional) {
X fargs = cdr(fargs);
X
X /* bind the arguments that were supplied */
X while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
X
X /* bind the formal variable to the argument value */
X xlbind(arg,car(aargs),env);
X
X /* move the argument list pointers ahead */
X fargs = cdr(fargs);
X aargs = cdr(aargs);
X }
X
X /* bind the rest to nil */
X while (consp(fargs) && !iskeyword(arg = car(fargs))) {
X
X /* bind the formal variable to nil */
X xlbind(arg,NIL,env);
X
X /* move the argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* check for the '&rest' keyword */
X if (consp(fargs) && car(fargs) == k_rest) {
X fargs = cdr(fargs);
X if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
X xlbind(arg,aargs,env);
X else
X xlfail("symbol missing after &rest");
X fargs = cdr(fargs);
X aargs = NIL;
X }
X
X /* check for the '&aux' keyword */
X if (consp(fargs) && car(fargs) == k_aux)
X while ((fargs = cdr(fargs)) != NIL && consp(fargs))
X xlbind(car(fargs),NIL,env);
X
X /* make sure the correct number of arguments were supplied */
X if (fargs != aargs)
X xlfail(fargs ? "too few arguments" : "too many arguments");
X}
X
X/* iskeyword - check to see if a symbol is a keyword */
XLOCAL int iskeyword(sym)
X NODE *sym;
X{
X return (sym == k_optional || sym == k_rest || sym == k_aux);
X}
X
X/* xlsave - save nodes on the stack */
XNODE *xlsave(n)
X NODE *n;
X{
X NODE **nptr,*oldstk;
X
X /* save the old stack pointer */
X oldstk = xlstack;
X
X /* save each node */
X for (nptr = &n; *nptr != NULL; nptr++) {
X rplaca(*nptr,NIL);
X rplacd(*nptr,xlstack);
X xlstack = *nptr;
X }
X
X /* return the old stack pointer */
X return (oldstk);
X}
SHAR_EOF
if test 7937 -ne "`wc -c 'xleval.c'`"
then
echo shar: error transmitting "'xleval.c'" '(should have been 7937 characters)'
fi
echo shar: extracting "'xlfio.c'" '(6777 characters)'
if test -f 'xlfio.c'
then
echo shar: over-writing existing file "'xlfio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
X/* xlfio.c - xlisp file i/o */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *xlstack;
Xextern int xlfsize;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
X
X/* forward declarations */
XFORWARD NODE *printit();
XFORWARD NODE *flatsize();
XFORWARD NODE *openit();
X
X/* xread - read an expression */
XNODE *xread(args)
X NODE *args;
X{
X NODE *oldstk,fptr,eof,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&eof,NULL);
X
X /* get file pointer and eof value */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X eof.n_ptr = (args ? xlarg(&args) : NIL);
X xllastarg(args);
X
X /* read an expression */
X if (!xlread(fptr.n_ptr,&val))
X val = eof.n_ptr;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the expression */
X return (val);
X}
X
X/* xprint - builtin function 'print' */
XNODE *xprint(args)
X NODE *args;
X{
X return (printit(args,TRUE,TRUE));
X}
X
X/* xprin1 - builtin function 'prin1' */
XNODE *xprin1(args)
X NODE *args;
X{
X return (printit(args,TRUE,FALSE));
X}
X
X/* xprinc - builtin function princ */
XNODE *xprinc(args)
X NODE *args;
X{
X return (printit(args,FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XNODE *xterpri(args)
X NODE *args;
X{
X NODE *fptr;
X
X /* get file pointer */
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* terminate the print line and return nil */
X xlterpri(fptr);
X return (NIL);
X}
X
X/* printit - common print function */
XLOCAL NODE *printit(args,pflag,tflag)
X NODE *args; int pflag,tflag;
X{
X NODE *oldstk,fptr,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&val,NULL);
X
X /* get expression to print and file pointer */
X val.n_ptr = xlarg(&args);
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* print the value */
X xlprint(fptr.n_ptr,val.n_ptr,pflag);
X
X /* terminate the print line if necessary */
X if (tflag)
X xlterpri(fptr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val.n_ptr);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XNODE *xflatsize(args)
X NODE *args;
X{
X return (flatsize(args,TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XNODE *xflatc(args)
X NODE *args;
X{
X return (flatsize(args,FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL NODE *flatsize(args,pflag)
X NODE *args; int pflag;
X{
X NODE *oldstk,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* get the expression */
X val.n_ptr = xlarg(&args);
X xllastarg(args);
X
X /* print the value to compute its size */
X xlfsize = 0;
X xlprint(NIL,val.n_ptr,pflag);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the length of the expression */
X return (cvfixnum((FIXNUM)xlfsize));
X}
X
X/* xopeni - open an input file */
XNODE *xopeni(args)
X NODE *args;
X{
X return (openit(args,"r"));
X}
X
X/* xopeno - open an output file */
XNODE *xopeno(args)
X NODE *args;
X{
X return (openit(args,"w"));
X}
X
X/* openit - common file open routine */
XLOCAL NODE *openit(args,mode)
X NODE *args; char *mode;
X{
X NODE *fname,*val;
X FILE *fp;
X
X /* get the file name */
X fname = xlmatch(STR,&args);
X xllastarg(args);
X
X /* try to open the file */
X if ((fp = fopen(fname->n_str,mode)) != NULL) {
X val = newnode(FPTR);
X val->n_fp = fp;
X val->n_savech = 0;
X }
X else
X val = NIL;
X
X /* return the file pointer */
X return (val);
X}
X
X/* xclose - close a file */
XNODE *xclose(args)
X NODE *args;
X{
X NODE *fptr;
X
X /* get file pointer */
X fptr = xlmatch(FPTR,&args);
X xllastarg(args);
X
X /* make sure the file exists */
X if (fptr->n_fp == NULL)
X xlfail("file not open");
X
X /* close the file */
X fclose(fptr->n_fp);
X fptr->n_fp = NULL;
X
X /* return nil */
X return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XNODE *xrdchar(args)
X NODE *args;
X{
X NODE *fptr;
X int ch;
X
X /* get file pointer */
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* get character and check for eof */
X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XNODE *xpkchar(args)
X NODE *args;
X{
X NODE *flag,*fptr;
X int ch;
X
X /* peek flag and get file pointer */
X flag = (args ? xlarg(&args) : NIL);
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* skip leading white space and get a character */
X if (flag)
X while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X xlgetc(fptr);
X else
X ch = xlpeek(fptr);
X
X /* return the character */
X return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
X}
X
X/* xwrchar - write a character to a file */
XNODE *xwrchar(args)
X NODE *args;
X{
X NODE *fptr,*chr;
X
X /* get the character and file pointer */
X chr = xlmatch(INT,&args);
X fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* put character to the file */
X xlputc(fptr,(int)chr->n_int);
X
X /* return the character */
X return (chr);
X}
X
X/* xreadline - read a line from a file */
XNODE *xreadline(args)
X NODE *args;
X{
X NODE *oldstk,fptr,str;
X char *p,*sptr;
X int len,ch;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&str,NULL);
X
X /* get file pointer */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
X xllastarg(args);
X
X /* make a string node */
X str.n_ptr = newnode(STR);
X str.n_ptr->n_strtype = DYNAMIC;
X
X /* get character and check for eof */
X len = 0; p = buf;
X while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
X
X /* check for buffer overflow */
X if ((int)(p - buf) == STRMAX) {
X *p = 0;
X sptr = stralloc(len + STRMAX); *sptr = 0;
X if (len) {
X strcpy(sptr,str.n_ptr->n_str);
X strfree(str.n_ptr->n_str);
X }
X str.n_ptr->n_str = sptr;
X strcat(sptr,buf);
X len += STRMAX;
X p = buf;
X }
X
X /* store the character */
X *p++ = ch;
X }
X
X /* check for end of file */
X if (len == 0 && p == buf && ch == EOF) {
X xlstack = oldstk;
X return (NIL);
X }
X
X /* append the last substring */
X *p = 0;
X sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
X if (len) {
X strcpy(sptr,str.n_ptr->n_str);
X strfree(str.n_ptr->n_str);
X }
X str.n_ptr->n_str = sptr;
X strcat(sptr,buf);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the string */
X return (str.n_ptr);
X}
SHAR_EOF
if test 6777 -ne "`wc -c 'xlfio.c'`"
then
echo shar: error transmitting "'xlfio.c'" '(should have been 6777 characters)'
fi
echo shar: extracting "'xlftab1.c'" '(4118 characters)'
if test -f 'xlftab1.c'
then
echo shar: over-writing existing file "'xlftab1.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab1.c'
X/* xlftab1.c - xlisp function table - part 1 */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern NODE
X *xeval(),*xapply(),*xfuncall(),*xquote(),*xfunction(),*xbquote(),
X *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
X *xgensym(),*xmakesymbol(),*xintern(),
X *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xputprop(),*xremprop(),
X *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
X *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
X *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
X *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
X *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
X *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
X *xeq(),*xeql(),*xequal(),
X *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
X *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
X *xcatch(),*xthrow(),
X *xerror(),*xcerror(),*xbreak(),*xcleanup(),*xcontinue(),*xerrset(),
X *xbaktrace(),*xevalhook(),
X *xdo(),*xdostar(),*xdolist(),*xdotimes(),
X *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp();
X
X/* the function table */
Xstruct fdef ftab1[] = {
X
X /* evaluator functions */
X{ "EVAL", SUBR, xeval },
X{ "APPLY", SUBR, xapply },
X{ "FUNCALL", SUBR, xfuncall },
X{ "QUOTE", FSUBR, xquote },
X{ "FUNCTION", FSUBR, xfunction },
X{ "BACKQUOTE", FSUBR, xbquote },
X
X /* symbol functions */
X{ "SET", SUBR, xset },
X{ "SETQ", FSUBR, xsetq },
X{ "SETF", FSUBR, xsetf },
X{ "DEFUN", FSUBR, xdefun },
X{ "DEFMACRO", FSUBR, xdefmacro },
X{ "GENSYM", SUBR, xgensym },
X{ "MAKE-SYMBOL", SUBR, xmakesymbol },
X{ "INTERN", SUBR, xintern },
X{ "SYMBOL-NAME", SUBR, xsymname },
X{ "SYMBOL-VALUE", SUBR, xsymvalue },
X{ "SYMBOL-PLIST", SUBR, xsymplist },
X{ "GET", SUBR, xget },
X{ "PUTPROP", SUBR, xputprop },
X{ "REMPROP", SUBR, xremprop },
X
X /* list functions */
X{ "CAR", SUBR, xcar },
X{ "CAAR", SUBR, xcaar },
X{ "CADR", SUBR, xcadr },
X{ "CDR", SUBR, xcdr },
X{ "CDAR", SUBR, xcdar },
X{ "CDDR", SUBR, xcddr },
X{ "CONS", SUBR, xcons },
X{ "LIST", SUBR, xlist },
X{ "APPEND", SUBR, xappend },
X{ "REVERSE", SUBR, xreverse },
X{ "LAST", SUBR, xlast },
X{ "NTH", SUBR, xnth },
X{ "NTHCDR", SUBR, xnthcdr },
X{ "MEMBER", SUBR, xmember },
X{ "ASSOC", SUBR, xassoc },
X{ "SUBST", SUBR, xsubst },
X{ "SUBLIS", SUBR, xsublis },
X{ "REMOVE", SUBR, xremove },
X{ "LENGTH", SUBR, xlength },
X{ "MAPC", SUBR, xmapc },
X{ "MAPCAR", SUBR, xmapcar },
X{ "MAPL", SUBR, xmapl },
X{ "MAPLIST", SUBR, xmaplist },
X
X /* destructive list functions */
X{ "RPLACA", SUBR, xrplca },
X{ "RPLACD", SUBR, xrplcd },
X{ "NCONC", SUBR, xnconc },
X{ "DELETE", SUBR, xdelete },
X
X /* predicate functions */
X{ "ATOM", SUBR, xatom },
X{ "SYMBOLP", SUBR, xsymbolp },
X{ "NUMBERP", SUBR, xnumberp },
X{ "BOUNDP", SUBR, xboundp },
X{ "NULL", SUBR, xnull },
X{ "NOT", SUBR, xnull },
X{ "LISTP", SUBR, xlistp },
X{ "CONSP", SUBR, xconsp },
X{ "MINUSP", SUBR, xminusp },
X{ "ZEROP", SUBR, xzerop },
X{ "PLUSP", SUBR, xplusp },
X{ "EVENP", SUBR, xevenp },
X{ "ODDP", SUBR, xoddp },
X{ "EQ", SUBR, xeq },
X{ "EQL", SUBR, xeql },
X{ "EQUAL", SUBR, xequal },
X
X /* control functions */
X{ "COND", FSUBR, xcond },
X{ "AND", FSUBR, xand },
X{ "OR", FSUBR, xor },
X{ "LET", FSUBR, xlet },
X{ "LET*", FSUBR, xletstar },
X{ "IF", FSUBR, xif },
X{ "PROG", FSUBR, xprog },
X{ "PROG*", FSUBR, xprogstar },
X{ "PROG1", FSUBR, xprog1 },
X{ "PROG2", FSUBR, xprog2 },
X{ "PROGN", FSUBR, xprogn },
X{ "GO", FSUBR, xgo },
X{ "RETURN", SUBR, xreturn },
X{ "DO", FSUBR, xdo },
X{ "DO*", FSUBR, xdostar },
X{ "DOLIST", FSUBR, xdolist },
X{ "DOTIMES", FSUBR, xdotimes },
X{ "CATCH", FSUBR, xcatch },
X{ "THROW", SUBR, xthrow },
X
X /* debugging and error handling functions */
X{ "ERROR", SUBR, xerror },
X{ "CERROR", SUBR, xcerror },
X{ "BREAK", SUBR, xbreak },
X{ "CLEAN-UP", SUBR, xcleanup },
X{ "CONTINUE", SUBR, xcontinue },
X{ "ERRSET", FSUBR, xerrset },
X{ "BAKTRACE", SUBR, xbaktrace },
X{ "EVALHOOK", SUBR, xevalhook },
X
X{ 0 }
X};
SHAR_EOF
if test 4118 -ne "`wc -c 'xlftab1.c'`"
then
echo shar: error transmitting "'xlftab1.c'" '(should have been 4118 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlftab2.c
# xlglob.c
# xlinit.c
# xlio.c
# xlisp.c
# xljump.c
# xllist.c
# xlmath.c
# This archive created: Sat Jan 18 14:32:27 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlftab2.c'" '(2614 characters)'
if test -f 'xlftab2.c'
then
echo shar: over-writing existing file "'xlftab2.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab2.c'
X/* xlftab2.c - xlisp function table - part 2 */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern NODE
X *xfix(),*xfloat(),
X *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
X *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
X *xsin(),*xcos(),*xtan(),*xexpt(),*xexp(),*xsqrt(),
X *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
X *xstrcat(),*xsubstr(),*xstring(),*xchar(),
X *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
X *xflatsize(),*xflatc(),
X *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
X *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit(),
X *xpeek(),*xpoke(),*xaddressof();
X
X/* the function table */
Xstruct fdef ftab2[] = {
X
X /* arithmetic functions */
X{ "TRUNCATE", SUBR, xfix },
X{ "FLOAT", SUBR, xfloat },
X{ "+", SUBR, xadd },
X{ "-", SUBR, xsub },
X{ "*", SUBR, xmul },
X{ "/", SUBR, xdiv },
X{ "1+", SUBR, xadd1 },
X{ "1-", SUBR, xsub1 },
X{ "REM", SUBR, xrem },
X{ "MIN", SUBR, xmin },
X{ "MAX", SUBR, xmax },
X{ "ABS", SUBR, xabs },
X{ "SIN", SUBR, xsin },
X{ "COS", SUBR, xcos },
X{ "TAN", SUBR, xtan },
X{ "EXPT", SUBR, xexpt },
X{ "EXP", SUBR, xexp },
X{ "SQRT", SUBR, xsqrt },
X
X /* bitwise logical functions */
X{ "BIT-AND", SUBR, xbitand },
X{ "BIT-IOR", SUBR, xbitior },
X{ "BIT-XOR", SUBR, xbitxor },
X{ "BIT-NOT", SUBR, xbitnot },
X
X /* numeric comparison functions */
X{ "<", SUBR, xlss },
X{ "<=", SUBR, xleq },
X{ "=", SUBR, xequ },
X{ "/=", SUBR, xneq },
X{ ">=", SUBR, xgeq },
X{ ">", SUBR, xgtr },
X
X /* string functions */
X{ "STRCAT", SUBR, xstrcat },
X{ "SUBSTR", SUBR, xsubstr },
X{ "STRING", SUBR, xstring },
X{ "CHAR", SUBR, xchar },
X
X /* I/O functions */
X{ "READ", SUBR, xread },
X{ "PRINT", SUBR, xprint },
X{ "PRIN1", SUBR, xprin1 },
X{ "PRINC", SUBR, xprinc },
X{ "TERPRI", SUBR, xterpri },
X{ "FLATSIZE", SUBR, xflatsize },
X{ "FLATC", SUBR, xflatc },
X
X /* file I/O functions */
X{ "OPENI", SUBR, xopeni },
X{ "OPENO", SUBR, xopeno },
X{ "CLOSE", SUBR, xclose },
X{ "READ-CHAR", SUBR, xrdchar },
X{ "PEEK-CHAR", SUBR, xpkchar },
X{ "WRITE-CHAR", SUBR, xwrchar },
X{ "READ-LINE", SUBR, xreadline },
X
X /* system functions */
X{ "LOAD", SUBR, xload },
X{ "GC", SUBR, xgc },
X{ "EXPAND", SUBR, xexpand },
X{ "ALLOC", SUBR, xalloc },
X{ "MEM", SUBR, xmem },
X{ "TYPE-OF", SUBR, xtype },
X{ "EXIT", SUBR, xexit },
X{ "PEEK", SUBR, xpeek },
X{ "POKE", SUBR, xpoke },
X{ "ADDRESS-OF", SUBR, xaddressof },
X
X{ 0 }
X};
SHAR_EOF
if test 2614 -ne "`wc -c 'xlftab2.c'`"
then
echo shar: error transmitting "'xlftab2.c'" '(should have been 2614 characters)'
fi
echo shar: extracting "'xlglob.c'" '(2197 characters)'
if test -f 'xlglob.c'
then
echo shar: over-writing existing file "'xlglob.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlglob.c'
X/* xlglobals - xlisp global variables */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* symbols */
XNODE *true = NIL;
XNODE *s_quote = NIL, *s_function = NIL;
XNODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
XNODE *s_evalhook = NIL, *s_applyhook = NIL;
XNODE *s_lambda = NIL, *s_macro = NIL;
XNODE *s_stdin = NIL, *s_stdout = NIL;
XNODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
XNODE *s_car = NIL, *s_cdr = NIL;
XNODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
XNODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
XNODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
XNODE *a_subr = NIL, *a_fsubr = NIL;
XNODE *a_list = NIL, *a_sym = NIL, *a_int = NIL, *a_float = NIL;
XNODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
XNODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;
X
X/* evaluation variables */
XNODE *xlstack = NIL;
XNODE *xlenv = NIL;
X
X/* exception handling variables */
XCONTEXT *xlcontext = NULL; /* current exception handler */
XNODE *xlvalue = NIL; /* exception value */
X
X/* debugging variables */
Xint xldebug = 0; /* debug level */
Xint xltrace = -1; /* trace stack pointer */
XNODE **trace_stack = NULL; /* trace stack */
X
X/* gensym variables */
Xchar gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
Xint gsnumber = 1; /* gensym number */
X
X/* i/o variables */
Xint xlplevel = 0; /* prompt nesting level */
Xint xlfsize = 0; /* flat size of current print call */
Xint prompt = TRUE; /* input prompt flag */
X
X/* dynamic memory variables */
Xlong total = 0L; /* total memory in use */
Xint anodes = 0; /* number of nodes to allocate */
Xint nnodes = 0; /* number of nodes allocated */
Xint nsegs = 0; /* number of segments allocated */
Xint nfree = 0; /* number of nodes free */
Xint gccalls = 0; /* number of gc calls */
Xstruct segment *segs = NULL; /* list of allocated segments */
XNODE *fnodes = NIL; /* list of free nodes */
X
X/* object programming variables */
XNODE *self = NIL, *class = NIL, *object = NIL;
XNODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
Xint varcnt = 0;
X
X/* general purpose string buffer */
Xchar buf[STRMAX+1] = { 0 };
SHAR_EOF
if test 2197 -ne "`wc -c 'xlglob.c'`"
then
echo shar: error transmitting "'xlglob.c'" '(should have been 2197 characters)'
fi
echo shar: extracting "'xlinit.c'" '(3534 characters)'
if test -f 'xlinit.c'
then
echo shar: over-writing existing file "'xlinit.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlinit.c'
X/* xlinit.c - xlisp initialization module */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *true;
Xextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
Xextern NODE *s_lambda,*s_macro;
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *s_tracenable,*s_tlimit,*s_breakenable;
Xextern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
Xextern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
Xextern NODE *a_subr,*a_fsubr;
Xextern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
Xextern struct fdef ftab1[],ftab2[];
X
X/* xlinit - xlisp initialization routine */
Xxlinit()
X{
X struct fdef *fptr;
X NODE *sym;
X
X /* initialize xlisp (must be in this order) */
X xlminit(); /* initialize xldmem.c */
X xlsinit(); /* initialize xlsym.c */
X xldinit(); /* initialize xldbug.c */
X xloinit(); /* initialize xlobj.c */
X
X /* enter the builtin functions */
X for (fptr = ftab1; fptr->f_name; fptr++)
X xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
X for (fptr = ftab2; fptr->f_name; fptr++)
X xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
X#ifdef CPM68K
X xlginit();
X#endif
X#ifdef MEGAMAX
X macfinit();
X#endif
X
X /* enter the 't' symbol */
X true = xlsenter("T");
X true->n_symvalue = true;
X
X /* enter some important symbols */
X s_quote = xlsenter("QUOTE");
X s_function = xlsenter("FUNCTION");
X s_bquote = xlsenter("BACKQUOTE");
X s_comma = xlsenter("COMMA");
X s_comat = xlsenter("COMMA-AT");
X s_lambda = xlsenter("LAMBDA");
X s_macro = xlsenter("MACRO");
X s_eql = xlsenter("EQL");
X
X /* enter setf place specifiers */
X s_car = xlsenter("CAR");
X s_cdr = xlsenter("CDR");
X s_get = xlsenter("GET");
X s_svalue = xlsenter("SYMBOL-VALUE");
X s_splist = xlsenter("SYMBOL-PLIST");
X
X /* enter parameter list keywords */
X k_test = xlsenter(":TEST");
X k_tnot = xlsenter(":TEST-NOT");
X
X /* enter lambda list keywords */
X k_optional = xlsenter("&OPTIONAL");
X k_rest = xlsenter("&REST");
X k_aux = xlsenter("&AUX");
X
X /* enter *standard-input* and *standard-output* */
X s_stdin = xlsenter("*STANDARD-INPUT*");
X s_stdin->n_symvalue = newnode(FPTR);
X s_stdin->n_symvalue->n_fp = stdin;
X s_stdin->n_symvalue->n_savech = 0;
X s_stdout = xlsenter("*STANDARD-OUTPUT*");
X s_stdout->n_symvalue = newnode(FPTR);
X s_stdout->n_symvalue->n_fp = stdout;
X s_stdout->n_symvalue->n_savech = 0;
X
X /* enter the eval and apply hook variables */
X s_evalhook = xlsenter("*EVALHOOK*");
X s_evalhook->n_symvalue = NIL;
X s_applyhook = xlsenter("*APPLYHOOK*");
X s_applyhook->n_symvalue = NIL;
X
X /* enter the error traceback and the error break enable flags */
X s_tracenable = xlsenter("*TRACENABLE*");
X s_tracenable->n_symvalue = NIL;
X s_tlimit = xlsenter("*TRACELIMIT*");
X s_tlimit->n_symvalue = NIL;
X s_breakenable = xlsenter("*BREAKENABLE*");
X s_breakenable->n_symvalue = true;
X
X /* enter a copyright notice into the oblist */
X sym = xlsenter("**Copyright-1985-by-David-Betz**");
X sym->n_symvalue = true;
X
X /* enter type names */
X a_subr = xlsenter(":SUBR");
X a_fsubr = xlsenter(":FSUBR");
X a_list = xlsenter(":CONS");
X a_sym = xlsenter(":SYMBOL");
X a_int = xlsenter(":FIXNUM");
X a_float = xlsenter(":FLONUM");
X a_str = xlsenter(":STRING");
X a_obj = xlsenter(":OBJECT");
X a_fptr = xlsenter(":FILE");
X}
SHAR_EOF
if test 3534 -ne "`wc -c 'xlinit.c'`"
then
echo shar: error transmitting "'xlinit.c'" '(should have been 3534 characters)'
fi
echo shar: extracting "'xlio.c'" '(3109 characters)'
if test -f 'xlio.c'
then
echo shar: over-writing existing file "'xlio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlio.c'
X/* xlio - xlisp i/o routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern int xlplevel;
Xextern int xlfsize;
Xextern NODE *xlstack;
Xextern NODE *s_stdin;
Xextern int xldebug;
Xextern int prompt;
Xextern char buf[];
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X NODE *fptr;
X{
X NODE *lptr,*cptr;
X FILE *fp;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (consp(fptr)) {
X if ((lptr = car(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) ||
X (cptr = car(lptr)) == NIL || !fixp(cptr))
X xlfail("bad stream");
X if (rplaca(fptr,cdr(lptr)) == NIL)
X rplacd(fptr,NIL);
X ch = cptr->n_int;
X }
X }
X
X /* otherwise, check for a buffered file character */
X else if (ch = fptr->n_savech)
X fptr->n_savech = 0;
X
X /* otherwise, get a new character */
X else {
X
X /* get the file pointer */
X fp = fptr->n_fp;
X
X /* prompt if necessary */
X if (prompt && fp == stdin) {
X
X /* print the debug level */
X if (xldebug)
X { sprintf(buf,"%d:",xldebug); stdputstr(buf); }
X
X /* print the nesting level */
X if (xlplevel > 0)
X { sprintf(buf,"%d",xlplevel); stdputstr(buf); }
X
X /* print the prompt */
X stdputstr("> ");
X prompt = FALSE;
X }
X
X /* get the character */
X if (((ch = getc(fp)) == '\n' || ch == EOF) && fp == stdin)
X prompt = TRUE;
X
X /* check for input abort */
X if (fp == stdin && ch == '\007') {
X putchar('\n');
X xlabort("input aborted");
X }
X }
X
X /* return the character */
X return (ch);
X}
X
X/* xlpeek - peek at a character from a file or stream */
Xint xlpeek(fptr)
X NODE *fptr;
X{
X NODE *lptr,*cptr;
X int ch;
X
X /* check for input from nil */
X if (fptr == NIL)
X ch = EOF;
X
X /* otherwise, check for input from a stream */
X else if (consp(fptr)) {
X if ((lptr = car(fptr)) == NIL)
X ch = EOF;
X else {
X if (!consp(lptr) ||
X (cptr = car(lptr)) == NIL || !fixp(cptr))
X xlfail("bad stream");
X ch = cptr->n_int;
X }
X }
X
X /* otherwise, get the next file character and save it */
X else
X ch = fptr->n_savech = xlgetc(fptr);
X
X /* return the character */
X return (ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X NODE *fptr; int ch;
X{
X NODE *oldstk,lptr;
X
X /* count the character */
X xlfsize++;
X
X /* check for output to nil */
X if (fptr == NIL)
X ;
X
X /* otherwise, check for output to a stream */
X else if (consp(fptr)) {
X oldstk = xlsave(&lptr,NULL);
X lptr.n_ptr = newnode(LIST);
X rplaca(lptr.n_ptr,cvfixnum((FIXNUM)ch));
X if (cdr(fptr))
X rplacd(cdr(fptr),lptr.n_ptr);
X else
X rplaca(fptr,lptr.n_ptr);
X rplacd(fptr,lptr.n_ptr);
X xlstack = oldstk;
X }
X
X /* otherwise, output the character to a file */
X else
X putc(ch,fptr->n_fp);
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X if (!prompt)
X while (xlgetc(getvalue(s_stdin)) != '\n')
X ;
X}
SHAR_EOF
if test 3109 -ne "`wc -c 'xlio.c'`"
then
echo shar: error transmitting "'xlio.c'" '(should have been 3109 characters)'
fi
echo shar: extracting "'xlisp.c'" '(2176 characters)'
if test -f 'xlisp.c'
then
echo shar: over-writing existing file "'xlisp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.c'
X/* xlisp - an small version of lisp that supports object-oriented programming */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* define the banner line string */
X#define BANNER "XLISP version 1.5b, Copyright (c) 1985, by David Betz"
X
X/* external variables */
Xextern NODE *s_stdin,*s_stdout;
Xextern NODE *s_evalhook,*s_applyhook;
Xextern NODE *true;
X
X/* main - the main routine */
Xmain(argc,argv)
X int argc; char *argv[];
X{
X char fname[50];
X CONTEXT cntxt;
X NODE expr;
X int i;
X
X /* print the banner line */
X#ifdef MEGAMAX
X macinit(BANNER);
X#else
X printf("%s\n",BANNER);
X#endif
X
X /* setup initialization error handler */
X xlbegin(&cntxt,CF_ERROR,(NODE *) 1);
X if (setjmp(cntxt.c_jmpbuf)) {
X printf("fatal initialization error\n");
X exit();
X }
X
X /* initialize xlisp */
X xlinit();
X xlend(&cntxt);
X
X /* reset the error handler */
X xlbegin(&cntxt,CF_ERROR,true);
X
X /* load "init.lsp" */
X if (setjmp(cntxt.c_jmpbuf) == 0)
X#ifndef INITPATH
X xlload("init.lsp",FALSE,FALSE);
X#else
X xlload(INITPATH,FALSE,FALSE);
X#endif
X
X /* load any files mentioned on the command line */
X#ifndef MEGAMAX
X if (setjmp(cntxt.c_jmpbuf) == 0)
X for (i = 1; i < argc; i++) {
X sprintf(fname,"%s.lsp",argv[i]);
X if (!xlload(fname,TRUE,FALSE))
X xlfail("can't load file");
X }
X#endif
X
X /* create a new stack frame */
X xlsave(&expr,NULL);
X
X /* main command processing loop */
X while (TRUE) {
X
X /* setup the error return */
X if (setjmp(cntxt.c_jmpbuf)) {
X setvalue(s_evalhook,NIL);
X setvalue(s_applyhook,NIL);
X xlflush();
X }
X
X /* read an expression */
X if (!xlread(getvalue(s_stdin),&expr.n_ptr))
X break;
X
X /* evaluate the expression */
X expr.n_ptr = xleval(expr.n_ptr);
X
X /* print it */
X stdprint(expr.n_ptr);
X }
X xlend(&cntxt);
X}
X
X/* stdprint - print to standard output */
Xstdprint(expr)
X NODE *expr;
X{
X xlprint(getvalue(s_stdout),expr,TRUE);
X xlterpri(getvalue(s_stdout));
X}
X
X/* stdputstr - print a string to standard output */
Xstdputstr(str)
X char *str;
X{
X xlputstr(getvalue(s_stdout),str);
X}
X
SHAR_EOF
if test 2176 -ne "`wc -c 'xlisp.c'`"
then
echo shar: error transmitting "'xlisp.c'" '(should have been 2176 characters)'
fi
echo shar: extracting "'xljump.c'" '(2937 characters)'
if test -f 'xljump.c'
then
echo shar: over-writing existing file "'xljump.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xljump.c'
X/* xljump - execution context routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern CONTEXT *xlcontext;
Xextern NODE *xlvalue;
Xextern NODE *xlstack,*xlenv;
Xextern int xltrace,xldebug;
X
X/* xlbegin - beginning of an execution context */
Xxlbegin(cptr,flags,expr)
X CONTEXT *cptr; int flags; NODE *expr;
X{
X cptr->c_flags = flags;
X cptr->c_expr = expr;
X cptr->c_xlstack = xlstack;
X cptr->c_xlenv = xlenv;
X cptr->c_xltrace = xltrace;
X cptr->c_xlcontext = xlcontext;
X xlcontext = cptr;
X}
X
X/* xlend - end of an execution context */
Xxlend(cptr)
X CONTEXT *cptr;
X{
X xlcontext = cptr->c_xlcontext;
X}
X
X/* xljump - jump to a saved execution context */
Xxljump(cptr,type,val)
X CONTEXT *cptr; int type; NODE *val;
X{
X /* restore the state */
X xlcontext = cptr;
X xlstack = xlcontext->c_xlstack;
X xlenv = xlcontext->c_xlenv;
X xltrace = xlcontext->c_xltrace;
X xlvalue = val;
X
X /* call the handler */
X longjmp(xlcontext->c_jmpbuf,type);
X}
X
X/* xlcleanup - clean-up after an error */
Xxlcleanup()
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_CLEANUP)
X xljump(cptr,CF_CLEANUP,NIL);
X xlfail("not in a break loop");
X}
X
X/* xlcontinue - continue from an error */
Xxlcontinue()
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_CONTINUE)
X xljump(cptr,CF_CONTINUE,NIL);
X xlfail("not in a break loop");
X}
X
X/* xlgo - go to a label */
Xxlgo(label)
X NODE *label;
X{
X CONTEXT *cptr;
X NODE *p;
X
X /* find a tagbody context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_GO)
X for (p = cptr->c_expr; consp(p); p = cdr(p))
X if (car(p) == label)
X xljump(cptr,CF_GO,p);
X xlfail("no target for GO");
X}
X
X/* xlreturn - return from a block */
Xxlreturn(val)
X NODE *val;
X{
X CONTEXT *cptr;
X
X /* find a block context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_RETURN)
X xljump(cptr,CF_RETURN,val);
X xlfail("no target for RETURN");
X}
X
X/* xlthrow - throw to a catch */
Xxlthrow(tag,val)
X NODE *tag,*val;
X{
X CONTEXT *cptr;
X
X /* find a catch context */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
X xljump(cptr,CF_THROW,val);
X xlfail("no target for THROW");
X}
X
X/* xlsignal - signal an error */
Xxlsignal(emsg,arg)
X char *emsg; NODE *arg;
X{
X CONTEXT *cptr;
X
X /* find an error catcher */
X for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X if (cptr->c_flags & CF_ERROR) {
X if (cptr->c_expr)
X xlerrprint("error",NULL,emsg,arg);
X xljump(cptr,CF_ERROR,NIL);
X }
X xlfail("no target for error");
X}
SHAR_EOF
if test 2937 -ne "`wc -c 'xljump.c'`"
then
echo shar: error transmitting "'xljump.c'" '(should have been 2937 characters)'
fi
echo shar: extracting "'xllist.c'" '(18035 characters)'
if test -f 'xllist.c'
then
echo shar: over-writing existing file "'xllist.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xllist.c'
X/* xllist - xlisp built-in list functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "overflow"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern NODE *s_unbound;
Xextern NODE *true;
X
X/* external routines */
Xextern int eq(),eql(),equal();
X
X/* forward declarations */
XFORWARD NODE *cxr();
XFORWARD NODE *nth(),*assoc();
XFORWARD NODE *subst(),*sublis(),*map();
XFORWARD NODE *cequal();
X
X/* xcar - return the car of a list */
XNODE *xcar(args)
X NODE *args;
X{
X return (cxr(args,"a"));
X}
X
X/* xcdr - return the cdr of a list */
XNODE *xcdr(args)
X NODE *args;
X{
X return (cxr(args,"d"));
X}
X
X/* xcaar - return the caar of a list */
XNODE *xcaar(args)
X NODE *args;
X{
X return (cxr(args,"aa"));
X}
X
X/* xcadr - return the cadr of a list */
XNODE *xcadr(args)
X NODE *args;
X{
X return (cxr(args,"da"));
X}
X
X/* xcdar - return the cdar of a list */
XNODE *xcdar(args)
X NODE *args;
X{
X return (cxr(args,"ad"));
X}
X
X/* xcddr - return the cddr of a list */
XNODE *xcddr(args)
X NODE *args;
X{
X return (cxr(args,"dd"));
X}
X
X/* cxr - common car/cdr routine */
XLOCAL NODE *cxr(args,adstr)
X NODE *args; char *adstr;
X{
X NODE *list;
X
X /* get the list */
X list = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* perform the car/cdr operations */
X while (*adstr && consp(list))
X list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X /* make sure the operation succeeded */
X if (*adstr && list)
X xlfail("bad argument");
X
X /* return the result */
X return (list);
X}
X
X/* xcons - construct a new list cell */
XNODE *xcons(args)
X NODE *args;
X{
X NODE *arg1,*arg2,*val;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* construct a new list element */
X val = newnode(LIST);
X rplaca(val,arg1);
X rplacd(val,arg2);
X
X /* return the list */
X return (val);
X}
X
X/* xlist - built a list of the arguments */
XNODE *xlist(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,val,*last,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate and append each argument */
X for (last = NIL; arg.n_ptr != NIL; last = lptr) {
X
X /* evaluate the next argument */
X val.n_ptr = xlarg(&arg.n_ptr);
X
X /* append this argument to the end of the list */
X lptr = newnode(LIST);
X if (last == NIL)
X list.n_ptr = lptr;
X else
X rplacd(last,lptr);
X rplaca(lptr,val.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (list.n_ptr);
X}
X
X/* xappend - built-in function append */
XNODE *xappend(args)
X NODE *args;
X{
X NODE *oldstk,arg,list,last,val,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&list,&last,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate and append each argument */
X while (arg.n_ptr) {
X
X /* evaluate the next argument */
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* append each element of this list to the result list */
X while (consp(list.n_ptr)) {
X
X /* append this element */
X lptr = newnode(LIST);
X if (last.n_ptr == NIL)
X val.n_ptr = lptr;
X else
X rplacd(last.n_ptr,lptr);
X rplaca(lptr,car(list.n_ptr));
X
X /* save the new last element */
X last.n_ptr = lptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X }
X
X /* restore previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (val.n_ptr);
X}
X
X/* xreverse - built-in function reverse */
XNODE *xreverse(args)
X NODE *args;
X{
X NODE *oldstk,list,val,*lptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&list,&val,NULL);
X
X /* get the list to reverse */
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* append each element of this list to the result list */
X while (consp(list.n_ptr)) {
X
X /* append this element */
X lptr = newnode(LIST);
X rplaca(lptr,car(list.n_ptr));
X rplacd(lptr,val.n_ptr);
X val.n_ptr = lptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X
X /* restore previous stack frame */
X xlstack = oldstk;
X
X /* return the list */
X return (val.n_ptr);
X}
X
X/* xlast - return the last cons of a list */
XNODE *xlast(args)
X NODE *args;
X{
X NODE *list;
X
X /* get the list */
X list = xlmatch(LIST,&args);
X xllastarg(args);
X
X /* find the last cons */
X while (consp(list) && cdr(list))
X list = cdr(list);
X
X /* return the last element */
X return (list);
X}
X
X/* xmember - built-in function 'member' */
XNODE *xmember(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,NULL);
X
X /* get the expression to look for and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* look for the expression */
X for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
X val = list.n_ptr;
X break;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XNODE *xassoc(args)
X NODE *args;
X{
X NODE *oldstk,x,alist,fcn,*pair,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&alist,&fcn,NULL);
X
X /* get the expression to look for and the association list */
X x.n_ptr = xlarg(&args);
X alist.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* look for the expression */
X for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
X if ((pair = car(alist.n_ptr)) && consp(pair))
X if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
X val = pair;
X break;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xsubst - substitute one expression for another */
XNODE *xsubst(args)
X NODE *args;
X{
X NODE *oldstk,to,from,expr,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
X
X /* get the to value, the from value and the expression */
X to.n_ptr = xlarg(&args);
X from.n_ptr = xlarg(&args);
X expr.n_ptr = xlarg(&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* do the substitution */
X val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* subst - substitute one expression for another */
XLOCAL NODE *subst(to,from,expr,fcn,tresult)
X NODE *to,*from,*expr,*fcn; int tresult;
X{
X NODE *oldstk,carval,cdrval,*val;
X
X if (dotest(expr,from,fcn) == tresult)
X val = to;
X else if (consp(expr)) {
X oldstk = xlsave(&carval,&cdrval,NULL);
X carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
X cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
X val = newnode(LIST);
X rplaca(val,carval.n_ptr);
X rplacd(val,cdrval.n_ptr);
X xlstack = oldstk;
X }
X else
X val = expr;
X return (val);
X}
X
X/* xsublis - substitute using an association list */
XNODE *xsublis(args)
X NODE *args;
X{
X NODE *oldstk,alist,expr,fcn,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&alist,&expr,&fcn,NULL);
X
X /* get the assocation list and the expression */
X alist.n_ptr = xlmatch(LIST,&args);
X expr.n_ptr = xlarg(&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* do the substitution */
X val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* sublis - substitute using an association list */
XLOCAL NODE *sublis(alist,expr,fcn,tresult)
X NODE *alist,*expr,*fcn; int tresult;
X{
X NODE *oldstk,carval,cdrval,*val;
X
X if (val = assoc(expr,alist,fcn,tresult))
X val = cdr(val);
X else if (consp(expr)) {
X oldstk = xlsave(&carval,&cdrval,NULL);
X carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
X cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
X val = newnode(LIST);
X rplaca(val,carval.n_ptr);
X rplacd(val,cdrval.n_ptr);
X xlstack = oldstk;
X }
X else
X val = expr;
X return (val);
X}
X
X/* assoc - find a pair in an association list */
XLOCAL NODE *assoc(expr,alist,fcn,tresult)
X NODE *expr,*alist,*fcn; int tresult;
X{
X NODE *pair;
X
X for (; consp(alist); alist = cdr(alist))
X if ((pair = car(alist)) && consp(pair))
X if (dotest(expr,car(pair),fcn) == tresult)
X return (pair);
X return (NIL);
X}
X
X/* xremove - built-in function 'remove' */
XNODE *xremove(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,val,*p,*last;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,&val,NULL);
X
X /* get the expression to remove and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* remove matches */
X while (consp(list.n_ptr)) {
X
X /* check to see if this element should be deleted */
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
X p = newnode(LIST);
X rplaca(p,car(list.n_ptr));
X if (val.n_ptr) rplacd(last,p);
X else val.n_ptr = p;
X last = p;
X }
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the updated list */
X return (val.n_ptr);
X}
X
X/* dotest - call a test function */
Xint dotest(arg1,arg2,fcn)
X NODE *arg1,*arg2,*fcn;
X{
X NODE *oldstk,args,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&args,NULL);
X
X /* build an argument list */
X args.n_ptr = newnode(LIST);
X rplaca(args.n_ptr,arg1);
X rplacd(args.n_ptr,newnode(LIST));
X rplaca(cdr(args.n_ptr),arg2);
X
X /* apply the test function */
X val = xlapply(fcn,args.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result of the test */
X return (val != NIL);
X}
X
X/* xnth - return the nth element of a list */
XNODE *xnth(args)
X NODE *args;
X{
X return (nth(args,TRUE));
X}
X
X/* xnthcdr - return the nth cdr of a list */
XNODE *xnthcdr(args)
X NODE *args;
X{
X return (nth(args,FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL NODE *nth(args,carflag)
X NODE *args; int carflag;
X{
X NODE *list;
X int n;
X
X /* get n and the list */
X if ((n = xlmatch(INT,&args)->n_int) < 0)
X xlfail("bad argument");
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X xllastarg(args);
X
X /* find the nth element */
X while (consp(list) && n--)
X list = cdr(list);
X
X /* return the list beginning at the nth element */
X return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xlength - return the length of a list or string */
XNODE *xlength(args)
X NODE *args;
X{
X NODE *arg;
X int n;
X
X /* get the list or string */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* find the length of a list */
X if (listp(arg))
X for (n = 0; consp(arg); n++)
X arg = cdr(arg);
X
X /* find the length of a string */
X else if (stringp(arg))
X n = strlen(arg->n_str);
X
X /* otherwise, bad argument type */
X else
X xlerror("bad argument type",arg);
X
X /* return the length */
X return (cvfixnum((FIXNUM)n));
X}
X
X/* xmapc - built-in function 'mapc' */
XNODE *xmapc(args)
X NODE *args;
X{
X return (map(args,TRUE,FALSE));
X}
X
X/* xmapcar - built-in function 'mapcar' */
XNODE *xmapcar(args)
X NODE *args;
X{
X return (map(args,TRUE,TRUE));
X}
X
X/* xmapl - built-in function 'mapl' */
XNODE *xmapl(args)
X NODE *args;
X{
X return (map(args,FALSE,FALSE));
X}
X
X/* xmaplist - built-in function 'maplist' */
XNODE *xmaplist(args)
X NODE *args;
X{
X return (map(args,FALSE,TRUE));
X}
X
X/* map - internal mapping function */
XLOCAL NODE *map(args,carflag,valflag)
X NODE *args; int carflag,valflag;
X{
X NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
X
X /* create a new stack frame */
X oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
X
X /* get the function to apply and the first list */
X fcn.n_ptr = xlarg(&args);
X lists.n_ptr = xlmatch(LIST,&args);
X
X /* save the first list if not saving function values */
X if (!valflag)
X val.n_ptr = lists.n_ptr;
X
X /* set up the list of argument lists */
X p = newnode(LIST);
X rplaca(p,lists.n_ptr);
X lists.n_ptr = p;
X
X /* get the remaining argument lists */
X while (args) {
X p = newnode(LIST);
X rplacd(p,lists.n_ptr);
X lists.n_ptr = p;
X rplaca(p,xlmatch(LIST,&args));
X }
X
X /* if the function is a symbol, get its value */
X if (symbolp(fcn.n_ptr))
X fcn.n_ptr = xleval(fcn.n_ptr);
X
X /* loop through each of the argument lists */
X for (;;) {
X
X /* build an argument list from the sublists */
X arglist.n_ptr = NIL;
X for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
X p = newnode(LIST);
X rplacd(p,arglist.n_ptr);
X arglist.n_ptr = p;
X rplaca(p,carflag ? car(y) : y);
X rplaca(x,cdr(y));
X }
X
X /* quit if any of the lists were empty */
X if (x) break;
X
X /* apply the function to the arguments */
X if (valflag) {
X p = newnode(LIST);
X if (val.n_ptr) rplacd(last,p);
X else val.n_ptr = p;
X rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
X last = p;
X }
X else
X xlapply(fcn.n_ptr,arglist.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val.n_ptr);
X}
X
X/* xrplca - replace the car of a list node */
XNODE *xrplca(args)
X NODE *args;
X{
X NODE *list,*newcar;
X
X /* get the list and the new car */
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X newcar = xlarg(&args);
X xllastarg(args);
X
X /* replace the car */
X rplaca(list,newcar);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xrplcd - replace the cdr of a list node */
XNODE *xrplcd(args)
X NODE *args;
X{
X NODE *list,*newcdr;
X
X /* get the list and the new cdr */
X if ((list = xlmatch(LIST,&args)) == NIL)
X xlfail("bad argument");
X newcdr = xlarg(&args);
X xllastarg(args);
X
X /* replace the cdr */
X rplacd(list,newcdr);
X
X /* return the list node that was modified */
X return (list);
X}
X
X/* xnconc - destructively append lists */
XNODE *xnconc(args)
X NODE *args;
X{
X NODE *list,*last,*val;
X
X /* concatenate each argument */
X for (val = NIL; args; ) {
X
X /* concatenate this list */
X if (list = xlmatch(LIST,&args)) {
X
X /* check for this being the first non-empty list */
X if (val)
X rplacd(last,list);
X else
X val = list;
X
X /* find the end of the list */
X while (consp(cdr(list)))
X list = cdr(list);
X
X /* save the new last element */
X last = list;
X }
X }
X
X /* return the list */
X return (val);
X}
X
X/* xdelete - built-in function 'delete' */
XNODE *xdelete(args)
X NODE *args;
X{
X NODE *oldstk,x,list,fcn,*last,*val;
X int tresult;
X
X /* create a new stack frame */
X oldstk = xlsave(&x,&list,&fcn,NULL);
X
X /* get the expression to delete and the list */
X x.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xltest(&fcn.n_ptr,&tresult,&args);
X xllastarg(args);
X
X /* delete leading matches */
X while (consp(list.n_ptr)) {
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
X break;
X list.n_ptr = cdr(list.n_ptr);
X }
X val = last = list.n_ptr;
X
X /* delete embedded matches */
X if (consp(list.n_ptr)) {
X
X /* skip the first non-matching element */
X list.n_ptr = cdr(list.n_ptr);
X
X /* look for embedded matches */
X while (consp(list.n_ptr)) {
X
X /* check to see if this element should be deleted */
X if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
X rplacd(last,cdr(list.n_ptr));
X else
X last = list.n_ptr;
X
X /* move to the next element */
X list.n_ptr = cdr(list.n_ptr);
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the updated list */
X return (val);
X}
X
X/* xatom - is this an atom? */
XNODE *xatom(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (atom(arg) ? true : NIL);
X}
X
X/* xsymbolp - is this an symbol? */
XNODE *xsymbolp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (arg == NIL || symbolp(arg) ? true : NIL);
X}
X
X/* xnumberp - is this a number? */
XNODE *xnumberp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (fixp(arg) || floatp(arg) ? true : NIL);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XNODE *xboundp(args)
X NODE *args;
X{
X NODE *sym;
X sym = xlmatch(SYM,&args);
X xllastarg(args);
X return (xlxgetvalue(sym) == s_unbound ? NIL : true);
X}
X
X/* xnull - is this null? */
XNODE *xnull(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (null(arg) ? true : NIL);
X}
X
X/* xlistp - is this a list? */
XNODE *xlistp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (listp(arg) ? true : NIL);
X}
X
X/* xconsp - is this a cons? */
XNODE *xconsp(args)
X NODE *args;
X{
X NODE *arg;
X arg = xlarg(&args);
X xllastarg(args);
X return (consp(arg) ? true : NIL);
X}
X
X/* xeq - are these equal? */
XNODE *xeq(args)
X NODE *args;
X{
X return (cequal(args,eq));
X}
X
X/* xeql - are these equal? */
XNODE *xeql(args)
X NODE *args;
X{
X return (cequal(args,eql));
X}
X
X/* xequal - are these equal? */
XNODE *xequal(args)
X NODE *args;
X{
X return (cequal(args,equal));
X}
X
X/* cequal - common eq/eql/equal function */
XLOCAL NODE *cequal(args,fcn)
X NODE *args; int (*fcn)();
X{
X NODE *arg1,*arg2;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* compare the arguments */
X return ((*fcn)(arg1,arg2) ? true : NIL);
X}
SHAR_EOF
if test 18035 -ne "`wc -c 'xllist.c'`"
then
echo shar: error transmitting "'xllist.c'" '(should have been 18035 characters)'
fi
echo shar: extracting "'xlmath.c'" '(10134 characters)'
if test -f 'xlmath.c'
then
echo shar: over-writing existing file "'xlmath.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlmath.c'
X/* xlmath - xlisp builtin arithmetic functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include <math.h>
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "math"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern NODE *true;
X
X/* forward declarations */
XFORWARD NODE *unary();
XFORWARD NODE *binary();
XFORWARD NODE *predicate();
XFORWARD NODE *compare();
X
X/* xadd - builtin function for addition */
XNODE *xadd(args)
X NODE *args;
X{
X return (binary(args,'+'));
X}
X
X/* xsub - builtin function for subtraction */
XNODE *xsub(args)
X NODE *args;
X{
X return (binary(args,'-'));
X}
X
X/* xmul - builtin function for multiplication */
XNODE *xmul(args)
X NODE *args;
X{
X return (binary(args,'*'));
X}
X
X/* xdiv - builtin function for division */
XNODE *xdiv(args)
X NODE *args;
X{
X return (binary(args,'/'));
X}
X
X/* xrem - builtin function for remainder */
XNODE *xrem(args)
X NODE *args;
X{
X return (binary(args,'%'));
X}
X
X/* xmin - builtin function for minimum */
XNODE *xmin(args)
X NODE *args;
X{
X return (binary(args,'m'));
X}
X
X/* xmax - builtin function for maximum */
XNODE *xmax(args)
X NODE *args;
X{
X return (binary(args,'M'));
X}
X
X/* xexpt - built-in function 'expt' */
XNODE *xexpt(args)
X NODE *args;
X{
X return (binary(args,'E'));
X}
X
X/* xbitand - builtin function for bitwise and */
XNODE *xbitand(args)
X NODE *args;
X{
X return (binary(args,'&'));
X}
X
X/* xbitior - builtin function for bitwise inclusive or */
XNODE *xbitior(args)
X NODE *args;
X{
X return (binary(args,'|'));
X}
X
X/* xbitxor - builtin function for bitwise exclusive or */
XNODE *xbitxor(args)
X NODE *args;
X{
X return (binary(args,'^'));
X}
X
X/* binary - handle binary operations */
XLOCAL NODE *binary(args,fcn)
X NODE *args; int fcn;
X{
X FIXNUM ival,iarg;
X FLONUM fval,farg;
X NODE *arg;
X int imode;
X
X /* get the first argument */
X arg = xlarg(&args);
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = arg->n_int;
X imode = TRUE;
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X imode = FALSE;
X }
X else
X xlerror("bad argument type",arg);
X
X /* treat '-' with a single argument as a special case */
X if (fcn == '-' && args == NIL)
X if (imode)
X ival = -ival;
X else
X fval = -fval;
X
X /* handle each remaining argument */
X while (args) {
X
X /* get the next argument */
X arg = xlarg(&args);
X
X /* check its type */
X if (fixp(arg))
X if (imode) iarg = arg->n_int;
X else farg = (FLONUM)arg->n_int;
X else if (floatp(arg))
X if (imode) { fval = (FLONUM)ival; farg = arg->n_float; imode = FALSE; }
X else farg = arg->n_float;
X else
X xlerror("bad argument type",arg);
X
X /* accumulate the result value */
X if (imode)
X switch (fcn) {
X case '+': ival += iarg; break;
X case '-': ival -= iarg; break;
X case '*': ival *= iarg; break;
X case '/': checkizero(iarg); ival /= iarg; break;
X case '%': checkizero(iarg); ival %= iarg; break;
X case 'M': if (iarg > ival) ival = iarg; break;
X case 'm': if (iarg < ival) ival = iarg; break;
X case '&': ival &= iarg; break;
X case '|': ival |= iarg; break;
X case '^': ival ^= iarg; break;
X default: badiop();
X }
X else
X switch (fcn) {
X case '+': fval += farg; break;
X case '-': fval -= farg; break;
X case '*': fval *= farg; break;
X case '/': checkfzero(farg); fval /= farg; break;
X case 'M': if (farg > fval) fval = farg; break;
X case 'm': if (farg < fval) fval = farg; break;
X case 'E': fval = pow(fval,farg); break;
X default: badfop();
X }
X }
X
X /* return the result */
X return (imode ? cvfixnum(ival) : cvflonum(fval));
X}
X
X/* checkizero - check for integer division by zero */
Xcheckizero(iarg)
X FIXNUM iarg;
X{
X if (iarg == 0)
X xlfail("division by zero");
X}
X
X/* checkfzero - check for floating point division by zero */
Xcheckfzero(farg)
X FLONUM farg;
X{
X if (farg == 0.0)
X xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
Xcheckfneg(farg)
X FLONUM farg;
X{
X if (farg < 0.0)
X xlfail("square root of a negative number");
X}
X
X/* xbitnot - bitwise not */
XNODE *xbitnot(args)
X NODE *args;
X{
X return (unary(args,'~'));
X}
X
X/* xabs - builtin function for absolute value */
XNODE *xabs(args)
X NODE *args;
X{
X return (unary(args,'A'));
X}
X
X/* xadd1 - builtin function for adding one */
XNODE *xadd1(args)
X NODE *args;
X{
X return (unary(args,'+'));
X}
X
X/* xsub1 - builtin function for subtracting one */
XNODE *xsub1(args)
X NODE *args;
X{
X return (unary(args,'-'));
X}
X
X/* xsin - built-in function 'sin' */
XNODE *xsin(args)
X NODE *args;
X{
X return (unary(args,'S'));
X}
X
X/* xcos - built-in function 'cos' */
XNODE *xcos(args)
X NODE *args;
X{
X return (unary(args,'C'));
X}
X
X/* xtan - built-in function 'tan' */
XNODE *xtan(args)
X NODE *args;
X{
X return (unary(args,'T'));
X}
X
X/* xexp - built-in function 'exp' */
XNODE *xexp(args)
X NODE *args;
X{
X return (unary(args,'E'));
X}
X
X/* xsqrt - built-in function 'sqrt' */
XNODE *xsqrt(args)
X NODE *args;
X{
X return (unary(args,'R'));
X}
X
X/* xfix - built-in function 'fix' */
XNODE *xfix(args)
X NODE *args;
X{
X return (unary(args,'I'));
X}
X
X/* xfloat - built-in function 'float' */
XNODE *xfloat(args)
X NODE *args;
X{
X return (unary(args,'F'));
X}
X
X/* unary - handle unary operations */
XLOCAL NODE *unary(args,fcn)
X NODE *args; int fcn;
X{
X FLONUM fval;
X FIXNUM ival;
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* check its type */
X if (fixp(arg)) {
X ival = arg->n_int;
X switch (fcn) {
X case '~': ival = ~ival; break;
X case 'A': ival = abs(ival); break;
X case '+': ival++; break;
X case '-': ival--; break;
X case 'I': break;
X case 'F': return (cvflonum((FLONUM)ival));
X default: badiop();
X }
X return (cvfixnum(ival));
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X switch (fcn) {
X case 'A': fval = fabs(fval); break;
X case '+': fval += 1.0; break;
X case '-': fval -= 1.0; break;
X case 'S': fval = sin(fval); break;
X case 'C': fval = cos(fval); break;
X case 'T': fval = tan(fval); break;
X case 'E': fval = exp(fval); break;
X case 'R': checkfneg(fval); fval = sqrt(fval); break;
X case 'I': return (cvfixnum((FIXNUM)fval));
X case 'F': break;
X default: badfop();
X }
X return (cvflonum(fval));
X }
X else
X xlerror("bad argument type",arg);
X}
X
X/* xminusp - is this number negative? */
XNODE *xminusp(args)
X NODE *args;
X{
X return (predicate(args,'-'));
X}
X
X/* xzerop - is this number zero? */
XNODE *xzerop(args)
X NODE *args;
X{
X return (predicate(args,'Z'));
X}
X
X/* xplusp - is this number positive? */
XNODE *xplusp(args)
X NODE *args;
X{
X return (predicate(args,'+'));
X}
X
X/* xevenp - is this number even? */
XNODE *xevenp(args)
X NODE *args;
X{
X return (predicate(args,'E'));
X}
X
X/* xoddp - is this number odd? */
XNODE *xoddp(args)
X NODE *args;
X{
X return (predicate(args,'O'));
X}
X
X/* predicate - handle a predicate function */
XLOCAL NODE *predicate(args,fcn)
X NODE *args; int fcn;
X{
X FLONUM fval;
X FIXNUM ival;
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(&args);
X xllastarg(args);
X
X /* check the argument type */
X if (fixp(arg)) {
X ival = arg->n_int;
X switch (fcn) {
X case '-': ival = (ival < 0); break;
X case 'Z': ival = (ival == 0); break;
X case '+': ival = (ival > 0); break;
X case 'E': ival = ((ival & 1) == 0); break;
X case 'O': ival = ((ival & 1) != 0); break;
X default: badiop();
X }
X }
X else if (floatp(arg)) {
X fval = arg->n_float;
X switch (fcn) {
X case '-': ival = (fval < 0); break;
X case 'Z': ival = (fval == 0); break;
X case '+': ival = (fval > 0); break;
X default: badfop();
X }
X }
X else
X xlerror("bad argument type",arg);
X
X /* return the result value */
X return (ival ? true : NIL);
X}
X
X/* xlss - builtin function for < */
XNODE *xlss(args)
X NODE *args;
X{
X return (compare(args,'<'));
X}
X
X/* xleq - builtin function for <= */
XNODE *xleq(args)
X NODE *args;
X{
X return (compare(args,'L'));
X}
X
X/* equ - builtin function for = */
XNODE *xequ(args)
X NODE *args;
X{
X return (compare(args,'='));
X}
X
X/* xneq - builtin function for /= */
XNODE *xneq(args)
X NODE *args;
X{
X return (compare(args,'#'));
X}
X
X/* xgeq - builtin function for >= */
XNODE *xgeq(args)
X NODE *args;
X{
X return (compare(args,'G'));
X}
X
X/* xgtr - builtin function for > */
XNODE *xgtr(args)
X NODE *args;
X{
X return (compare(args,'>'));
X}
X
X/* compare - common compare function */
XLOCAL NODE *compare(args,fcn)
X NODE *args; int fcn;
X{
X NODE *arg1,*arg2;
X FIXNUM icmp;
X FLONUM fcmp;
X int imode;
X
X /* get the two arguments */
X arg1 = xlarg(&args);
X arg2 = xlarg(&args);
X xllastarg(args);
X
X /* do the compare */
X if (stringp(arg1) && stringp(arg2)) {
X icmp = strcmp(arg1->n_str,arg2->n_str);
X imode = TRUE;
X }
X else if (fixp(arg1) && fixp(arg2)) {
X icmp = arg1->n_int - arg2->n_int;
X imode = TRUE;
X }
X else if (floatp(arg1) && floatp(arg2)) {
X fcmp = arg1->n_float - arg2->n_float;
X imode = FALSE;
X }
X else if (fixp(arg1) && floatp(arg2)) {
X fcmp = (FLONUM)arg1->n_int - arg2->n_float;
X imode = FALSE;
X }
X else if (floatp(arg1) && fixp(arg2)) {
X fcmp = arg1->n_float - (FLONUM)arg2->n_int;
X imode = FALSE;
X }
X else
X xlfail("expecting strings, integers or floats");
X
X /* compute result of the compare */
X if (imode)
X switch (fcn) {
X case '<': icmp = (icmp < 0); break;
X case 'L': icmp = (icmp <= 0); break;
X case '=': icmp = (icmp == 0); break;
X case '#': icmp = (icmp != 0); break;
X case 'G': icmp = (icmp >= 0); break;
X case '>': icmp = (icmp > 0); break;
X }
X else
X switch (fcn) {
X case '<': icmp = (fcmp < 0.0); break;
X case 'L': icmp = (fcmp <= 0.0); break;
X case '=': icmp = (fcmp == 0.0); break;
X case '#': icmp = (fcmp != 0.0); break;
X case 'G': icmp = (fcmp >= 0.0); break;
X case '>': icmp = (fcmp > 0.0); break;
X }
X
X /* return the result */
X return (icmp ? true : NIL);
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X xlfail("bad floating point operation");
X}
SHAR_EOF
if test 10134 -ne "`wc -c 'xlmath.c'`"
then
echo shar: error transmitting "'xlmath.c'" '(should have been 10134 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155bammi@cwruecmp.UUCP (Jwahar R. Bammi) (01/18/86)
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlobj.c
# xlprin.c
# xlread.c
# xlstr.c
# xlsubr.c
# xlsym.c
# xlsys.c
# This archive created: Sat Jan 18 14:32:30 1986
# By: Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlobj.c'" '(14267 characters)'
if test -f 'xlobj.c'
then
echo shar: over-writing existing file "'xlobj.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
X/* xlobj - xlisp object functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "overflow"
X#endif
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern NODE *s_stdout;
Xextern NODE *self,*msgclass,*msgcls,*class,*object;
Xextern NODE *new,*isnew;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES 0 /* list of messages */
X#define IVARS 1 /* list of instance variable names */
X#define CVARS 2 /* list of class variable names */
X#define CVALS 3 /* list of class variable values */
X#define SUPERCLASS 4 /* pointer to the superclass */
X#define IVARCNT 5 /* number of class instance variables */
X#define IVARTOTAL 6 /* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE 7
X
X/* forward declarations */
XFORWARD NODE *entermsg();
XFORWARD NODE *findmsg();
XFORWARD NODE *sendmsg();
XFORWARD NODE *findvar();
XFORWARD NODE *getivar();
XFORWARD NODE *getcvar();
XFORWARD NODE *makelist();
X
X/* xlgetivar - get the value of an instance variable */
XNODE *xlgetivar(obj,num)
X NODE *obj; int num;
X{
X return (car(getivar(obj,num)));
X}
X
X/* xlsetivar - set the value of an instance variable */
Xxlsetivar(obj,num,val)
X NODE *obj; int num; NODE *val;
X{
X rplaca(getivar(obj,num),val);
X}
X
X/* xlclass - define a class */
XNODE *xlclass(name,vcnt)
X char *name; int vcnt;
X{
X NODE *sym,*cls;
X
X /* create the class */
X sym = xlsenter(name);
X setvalue(sym,cls = newnode(OBJ));
X cls->n_obclass = class;
X cls->n_obdata = makelist(CLASSSIZE);
X
X /* set the instance variable counts */
X xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
X xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
X
X /* set the superclass to 'Object' */
X xlsetivar(cls,SUPERCLASS,object);
X
X /* return the new class */
X return (cls);
X}
X
X/* xladdivar - enter an instance variable */
Xxladdivar(cls,var)
X NODE *cls; char *var;
X{
X NODE *ivar,*lptr;
X
X /* find the 'ivars' instance variable */
X ivar = getivar(cls,IVARS);
X
X /* add the instance variable */
X lptr = newnode(LIST);
X rplacd(lptr,car(ivar));
X rplaca(ivar,lptr);
X rplaca(lptr,xlsenter(var));
X}
X
X/* xladdmsg - add a message to a class */
Xxladdmsg(cls,msg,code)
X NODE *cls; char *msg; NODE *(*code)();
X{
X NODE *mptr;
X
X /* enter the message selector */
X mptr = entermsg(cls,xlsenter(msg));
X
X /* store the method for this message */
X rplacd(mptr,newnode(SUBR));
X cdr(mptr)->n_subr = code;
X}
X
X/* xlsend - send a message to an object (message in arg list) */
XNODE *xlsend(obj,args)
X NODE *obj,*args;
X{
X NODE *oldstk,arglist,*msg,*val;
X
X /* find the message binding for this message */
X if ((msg = findmsg(obj->n_obclass,xlevmatch(SYM,&args))) == NIL)
X xlfail("no method for this message");
X
X /* evaluate the arguments and send the message */
X oldstk = xlsave(&arglist,NULL);
X arglist.n_ptr = xlevlist(args);
X val = sendmsg(obj,msg,arglist.n_ptr);
X xlstack = oldstk;
X
X /* return the result */
X return (val);
X}
X
X/* xlobgetvalue - get the value of an instance variable */
Xint xlobgetvalue(sym,pval)
X NODE *sym,**pval;
X{
X NODE *bnd;
X if ((bnd = findvar(sym)) == NIL)
X return (FALSE);
X *pval = car(bnd);
X return (TRUE);
X}
X
X/* xlobsetvalue - set the value of an instance variable */
Xint xlobsetvalue(sym,val)
X NODE *sym,*val;
X{
X NODE *bnd;
X if ((bnd = findvar(sym)) == NIL)
X return (FALSE);
X rplaca(bnd,val);
X return (TRUE);
X}
X
X/* obisnew - default 'isnew' method */
XLOCAL NODE *obisnew(args)
X NODE *args;
X{
X xllastarg(args);
X return (xlygetvalue(self));
X}
X
X/* obclass - get the class of an object */
XLOCAL NODE *obclass(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* return the object's class */
X return (xlygetvalue(self)->n_obclass);
X}
X
X/* obshow - show the instance variables of an object */
XLOCAL NODE *obshow(args)
X NODE *args;
X{
X NODE *oldstk,fptr,*obj,*cls,*names;
X int ivtotal,n;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,NULL);
X
X /* get the file pointer */
X fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
X xllastarg(args);
X
X /* get the object and its class */
X obj = xlygetvalue(self);
X cls = obj->n_obclass;
X
X /* print the object and class */
X xlputstr(fptr.n_ptr,"Object is ");
X xlprint(fptr.n_ptr,obj,TRUE);
X xlputstr(fptr.n_ptr,", Class is ");
X xlprint(fptr.n_ptr,cls,TRUE);
X xlterpri(fptr.n_ptr);
X
X /* print the object's instance variables */
X for (cls = obj->n_obclass; cls; cls = xlgetivar(cls,SUPERCLASS)) {
X names = xlgetivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X xlputstr(fptr.n_ptr," ");
X xlprint(fptr.n_ptr,car(names),TRUE);
X xlputstr(fptr.n_ptr," = ");
X xlprint(fptr.n_ptr,xlgetivar(obj,n),TRUE);
X xlterpri(fptr.n_ptr);
X names = cdr(names);
X }
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the object */
X return (obj);
X}
X
X/* obsendsuper - send a message to an object's superclass */
XLOCAL NODE *obsendsuper(args)
X NODE *args;
X{
X NODE *obj,*super,*msg;
X
X /* get the object */
X obj = xlygetvalue(self);
X
X /* get the object's superclass */
X super = xlgetivar(obj->n_obclass,SUPERCLASS);
X
X /* find the message binding for this message */
X if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
X xlfail("no method for this message");
X
X /* send the message */
X return (sendmsg(obj,msg,args));
X}
X
X/* clnew - create a new object instance */
XLOCAL NODE *clnew()
X{
X NODE *oldstk,obj,*cls;
X
X /* create a new stack frame */
X oldstk = xlsave(&obj,NULL);
X
X /* get the class */
X cls = xlygetvalue(self);
X
X /* generate a new object */
X obj.n_ptr = newnode(OBJ);
X obj.n_ptr->n_obclass = cls;
X obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new object */
X return (obj.n_ptr);
X}
X
X/* clisnew - initialize a new class */
XLOCAL NODE *clisnew(args)
X NODE *args;
X{
X NODE *ivars,*cvars,*super,*cls;
X int n;
X
X /* get the ivars, cvars and superclass */
X ivars = xlmatch(LIST,&args);
X cvars = (args ? xlmatch(LIST,&args) : NIL);
X super = (args ? xlmatch(OBJ,&args) : object);
X xllastarg(args);
X
X /* get the new class object */
X cls = xlygetvalue(self);
X
X /* store the instance and class variable lists and the superclass */
X xlsetivar(cls,IVARS,ivars);
X xlsetivar(cls,CVARS,cvars);
X xlsetivar(cls,CVALS,makelist(listlength(cvars)));
X xlsetivar(cls,SUPERCLASS,super);
X
X /* compute the instance variable count */
X n = listlength(ivars);
X xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
X n += getivcnt(super,IVARTOTAL);
X xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
X
X /* return the new class object */
X return (cls);
X}
X
X/* clanswer - define a method for answering a message */
XLOCAL NODE *clanswer(args)
X NODE *args;
X{
X NODE *oldstk,arg,msg,fargs,code;
X NODE *obj,*mptr,*fptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* message symbol, formal argument list and code */
X msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
X fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
X code.n_ptr = xlmatch(LIST,&arg.n_ptr);
X xllastarg(arg.n_ptr);
X
X /* get the object node */
X obj = xlygetvalue(self);
X
X /* make a new message list entry */
X mptr = entermsg(obj,msg.n_ptr);
X
X /* setup the message node */
X rplacd(mptr,fptr = newnode(LIST));
X rplaca(fptr,fargs.n_ptr);
X rplacd(fptr,code.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the object */
X return (obj);
X}
X
X/* entermsg - add a message to a class */
XLOCAL NODE *entermsg(cls,msg)
X NODE *cls,*msg;
X{
X NODE *ivar,*lptr,*mptr;
X
X /* find the 'messages' instance variable */
X ivar = getivar(cls,MESSAGES);
X
X /* lookup the message */
X for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
X if (car(mptr = car(lptr)) == msg)
X return (mptr);
X
X /* allocate a new message entry if one wasn't found */
X lptr = newnode(LIST);
X rplacd(lptr,car(ivar));
X rplaca(ivar,lptr);
X rplaca(lptr,mptr = newnode(LIST));
X rplaca(mptr,msg);
X
X /* return the symbol node */
X return (mptr);
X}
X
X/* findmsg - find the message binding given an object and a class */
XLOCAL NODE *findmsg(cls,sym)
X NODE *cls,*sym;
X{
X NODE *lptr,*msg;
X
X /* look for the message in the class or superclasses */
X for (msgcls = cls; msgcls != NIL; ) {
X
X /* lookup the message in this class */
X for (lptr = xlgetivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
X if ((msg = car(lptr)) != NIL && car(msg) == sym)
X return (msg);
X
X /* look in class's superclass */
X msgcls = xlgetivar(msgcls,SUPERCLASS);
X }
X
X /* message not found */
X return (NIL);
X}
X
X/* sendmsg - send a message to an object */
XLOCAL NODE *sendmsg(obj,msg,args)
X NODE *obj,*msg,*args;
X{
X NODE *oldstk,oldenv,newenv,method,cptr,val,*isnewmsg;
X
X /* create a new stack frame */
X oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,NULL);
X
X /* get the method for this message */
X method.n_ptr = cdr(msg);
X
X /* make sure its a function or a subr */
X if (!subrp(method.n_ptr) && !consp(method.n_ptr))
X xlfail("bad method");
X
X /* create a new environment frame */
X newenv.n_ptr = xlframe(NIL);
X oldenv.n_ptr = xlenv;
X
X /* bind the symbols 'self' and 'msgclass' */
X xlbind(self,obj,newenv.n_ptr);
X xlbind(msgclass,msgcls,newenv.n_ptr);
X
X /* evaluate the function call */
X if (subrp(method.n_ptr)) {
X xlenv = newenv.n_ptr;
X val.n_ptr = (*method.n_ptr->n_subr)(args);
X }
X else {
X
X /* bind the formal arguments */
X xlabind(car(method.n_ptr),args,newenv.n_ptr);
X xlenv = newenv.n_ptr;
X
X /* execute the code */
X cptr.n_ptr = cdr(method.n_ptr);
X while (cptr.n_ptr != NIL)
X val.n_ptr = xlevarg(&cptr.n_ptr);
X }
X
X /* restore the environment */
X xlenv = oldenv.n_ptr;
X
X /* after creating an object, send it the "isnew" message */
X if (car(msg) == new && val.n_ptr != NIL) {
X if ((isnewmsg = findmsg(val.n_ptr->n_obclass,isnew)) == NIL)
X xlfail("no method for the isnew message");
X sendmsg(val.n_ptr,isnewmsg,args);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the result value */
X return (val.n_ptr);
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X NODE *cls; int ivar;
X{
X NODE *cnt;
X if ((cnt = xlgetivar(cls,ivar)) == NIL || !fixp(cnt))
X xlfail("bad value for instance variable count");
X return ((int)cnt->n_int);
X}
X
X/* findvar - find a class or instance variable */
XLOCAL NODE *findvar(sym)
X NODE *sym;
X{
X NODE *obj,*cls,*names;
X int ivtotal,n;
X
X /* get the current object and the message class */
X obj = xlygetvalue(self);
X cls = xlygetvalue(msgclass);
X if (!(objectp(obj) && objectp(cls)))
X return (NIL);
X
X /* find the instance or class variable */
X for (; objectp(cls); cls = xlgetivar(cls,SUPERCLASS)) {
X
X /* check the instance variables */
X names = xlgetivar(cls,IVARS);
X ivtotal = getivcnt(cls,IVARTOTAL);
X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X if (car(names) == sym)
X return (getivar(obj,n));
X names = cdr(names);
X }
X
X /* check the class variables */
X names = xlgetivar(cls,CVARS);
X for (n = 0; consp(names); ++n) {
X if (car(names) == sym)
X return (getcvar(cls,n));
X names = cdr(names);
X }
X }
X
X /* variable not found */
X return (NIL);
X}
X
X/* getivar - get an instance variable */
XLOCAL NODE *getivar(obj,num)
X NODE *obj; int num;
X{
X NODE *ivar;
X
X /* get the instance variable */
X for (ivar = obj->n_obdata; num > 0; num--)
X if (ivar != NIL)
X ivar = cdr(ivar);
X else
X xlfail("bad instance variable list");
X
X /* return the instance variable */
X return (ivar);
X}
X
X/* getcvar - get a class variable */
XLOCAL NODE *getcvar(cls,num)
X NODE *cls; int num;
X{
X NODE *cvar;
X
X /* get the class variable */
X for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
X if (cvar != NIL)
X cvar = cdr(cvar);
X else
X xlfail("bad class variable list");
X
X /* return the class variable */
X return (cvar);
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X NODE *list;
X{
X int len;
X for (len = 0; consp(list); len++)
X list = cdr(list);
X return (len);
X}
X
X/* makelist - make a list of nodes */
XLOCAL NODE *makelist(cnt)
X int cnt;
X{
X NODE *oldstk,list,*lnew;
X
X /* make the list */
X oldstk = xlsave(&list,NULL);
X for (; cnt > 0; cnt--) {
X lnew = newnode(LIST);
X rplacd(lnew,list.n_ptr);
X list.n_ptr = lnew;
X }
X xlstack = oldstk;
X
X /* return the list */
X return (list.n_ptr);
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X /* don't confuse the garbage collector */
X class = object = NIL;
X
X /* enter the object related symbols */
X self = xlsenter("SELF");
X msgclass = xlsenter("MSGCLASS");
X new = xlsenter(":NEW");
X isnew = xlsenter(":ISNEW");
X
X /* create the 'Class' object */
X class = xlclass("CLASS",CLASSSIZE);
X class->n_obclass = class;
X
X /* create the 'Object' object */
X object = xlclass("OBJECT",0);
X
X /* finish initializing 'class' */
X xlsetivar(class,SUPERCLASS,object);
X xladdivar(class,"IVARTOTAL"); /* ivar number 6 */
X xladdivar(class,"IVARCNT"); /* ivar number 5 */
X xladdivar(class,"SUPERCLASS"); /* ivar number 4 */
X xladdivar(class,"CVALS"); /* ivar number 3 */
X xladdivar(class,"CVARS"); /* ivar number 2 */
X xladdivar(class,"IVARS"); /* ivar number 1 */
X xladdivar(class,"MESSAGES"); /* ivar number 0 */
X xladdmsg(class,":NEW",clnew);
X xladdmsg(class,":ISNEW",clisnew);
X xladdmsg(class,":ANSWER",clanswer);
X
X /* finish initializing 'object' */
X xladdmsg(object,":ISNEW",obisnew);
X xladdmsg(object,":CLASS",obclass);
X xladdmsg(object,":SHOW",obshow);
X xladdmsg(object,":SENDSUPER",obsendsuper);
X}
SHAR_EOF
if test 14267 -ne "`wc -c 'xlobj.c'`"
then
echo shar: error transmitting "'xlobj.c'" '(should have been 14267 characters)'
fi
echo shar: extracting "'xlprin.c'" '(3182 characters)'
if test -f 'xlprin.c'
then
echo shar: over-writing existing file "'xlprin.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
X/* xlprint - xlisp print routine */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *xlstack;
Xextern char buf[];
X
X/* xlprint - print an xlisp value */
Xxlprint(fptr,vptr,flag)
X NODE *fptr,*vptr; int flag;
X{
X NODE *nptr,*next;
X
X /* print nil */
X if (vptr == NIL) {
X xlputstr(fptr,"NIL");
X return;
X }
X
X /* check value type */
X switch (ntype(vptr)) {
X case SUBR:
X putatm(fptr,"Subr",vptr);
X break;
X case FSUBR:
X putatm(fptr,"FSubr",vptr);
X break;
X case LIST:
X xlputc(fptr,'(');
X for (nptr = vptr; nptr != NIL; nptr = next) {
X xlprint(fptr,car(nptr),flag);
X if (next = cdr(nptr))
X if (consp(next))
X xlputc(fptr,' ');
X else {
X xlputstr(fptr," . ");
X xlprint(fptr,next,flag);
X break;
X }
X }
X xlputc(fptr,')');
X break;
X case SYM:
X xlputstr(fptr,xlsymname(vptr));
X break;
X case INT:
X putdec(fptr,vptr->n_int);
X break;
X case FLOAT:
X putfloat(fptr,vptr->n_float);
X break;
X case STR:
X if (flag)
X putstring(fptr,vptr->n_str);
X else
X xlputstr(fptr,vptr->n_str);
X break;
X case FPTR:
X putatm(fptr,"File",vptr);
X break;
X case OBJ:
X putatm(fptr,"Object",vptr);
X break;
X case FREE:
X putatm(fptr,"Free",vptr);
X break;
X default:
X putatm(fptr,"Foo",vptr);
X break;
X }
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X NODE *fptr;
X{
X xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X NODE *fptr; char *str;
X{
X while (*str)
X xlputc(fptr,*str++);
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X NODE *fptr; char *str;
X{
X int ch;
X
X /* output the initial quote */
X xlputc(fptr,'"');
X
X /* output each character in the string */
X while (ch = *str++)
X
X /* check for a control character */
X if (ch < 040 || ch == '\\') {
X xlputc(fptr,'\\');
X switch (ch) {
X case '\033':
X xlputc(fptr,'e');
X break;
X case '\n':
X xlputc(fptr,'n');
X break;
X case '\r':
X xlputc(fptr,'r');
X break;
X case '\t':
X xlputc(fptr,'t');
X break;
X case '\\':
X xlputc(fptr,'\\');
X break;
X default:
X putoct(fptr,ch);
X break;
X }
X }
X
X /* output a normal character */
X else
X xlputc(fptr,ch);
X
X /* output the terminating quote */
X xlputc(fptr,'"');
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X NODE *fptr; char *tag; NODE *val;
X{
X sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
X sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X xlputc(fptr,'>');
X}
X
X/* putdec - output a decimal number */
XLOCAL putdec(fptr,n)
X NODE *fptr; FIXNUM n;
X{
X sprintf(buf,IFMT,n);
X xlputstr(fptr,buf);
X}
X
X/* putfloat - output a floating point number */
XLOCAL putfloat(fptr,n)
X NODE *fptr; FLONUM n;
X{
X sprintf(buf,FFMT,n);
X xlputstr(fptr,buf);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X NODE *fptr; int n;
X{
X sprintf(buf,"%03o",n);
X xlputstr(fptr,buf);
X}
SHAR_EOF
if test 3182 -ne "`wc -c 'xlprin.c'`"
then
echo shar: error transmitting "'xlprin.c'" '(should have been 3182 characters)'
fi
echo shar: extracting "'xlread.c'" '(9377 characters)'
if test -f 'xlread.c'
then
echo shar: over-writing existing file "'xlread.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlread.c'
X/* xlread - xlisp expression input routine */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X#ifdef MEGAMAX
Xoverlay "io"
X#endif
X
X/* external variables */
Xextern NODE *s_stdout,*true;
Xextern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
Xextern NODE *xlstack;
Xextern int xlplevel;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *fopen();
Xextern ITYPE;
Xextern FTYPE;
X
X/* forward declarations */
XFORWARD NODE *plist();
XFORWARD NODE *phexnumber();
XFORWARD NODE *pstring();
XFORWARD NODE *pquote();
XFORWARD NODE *pname();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X char *fname; int vflag,pflag;
X{
X NODE *oldstk,fptr,expr;
X CONTEXT cntxt;
X int sts;
X
X /* create a new stack frame */
X oldstk = xlsave(&fptr,&expr,NULL);
X
X /* allocate a file node */
X fptr.n_ptr = newnode(FPTR);
X fptr.n_ptr->n_fp = NULL;
X fptr.n_ptr->n_savech = 0;
X
X /* print the information line */
X if (vflag)
X { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
X
X /* open the file */
X if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
X xlstack = oldstk;
X return (FALSE);
X }
X
X /* read, evaluate and possibly print each expression in the file */
X xlbegin(&cntxt,CF_ERROR,true);
X if (setjmp(cntxt.c_jmpbuf))
X sts = FALSE;
X else {
X while (xlread(fptr.n_ptr,&expr.n_ptr)) {
X expr.n_ptr = xleval(expr.n_ptr);
X if (pflag)
X stdprint(expr.n_ptr);
X }
X sts = TRUE;
X }
X xlend(&cntxt);
X
X /* close the file */
X fclose(fptr.n_ptr->n_fp);
X fptr.n_ptr->n_fp = NULL;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return status */
X return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval)
X NODE *fptr,**pval;
X{
X /* initialize */
X xlplevel = 0;
X
X /* parse an expression */
X return (parse(fptr,pval));
X}
X
X/* parse - parse an xlisp expression */
XLOCAL int parse(fptr,pval)
X NODE *fptr,**pval;
X{
X int ch;
X
X /* keep looking for a node skipping comments */
X while (TRUE)
X
X /* check next character for type of node */
X switch (ch = nextch(fptr)) {
X case EOF:
X xlgetc(fptr);
X return (FALSE);
X case '\'': /* a quoted expression */
X xlgetc(fptr);
X *pval = pquote(fptr,s_quote);
X return (TRUE);
X case '#': /* a quoted function */
X xlgetc(fptr);
X switch (ch = xlgetc(fptr)) {
X case '<':
X xlfail("unreadable atom");
X case '\'':
X *pval = pquote(fptr,s_function);
X break;
X case 'x':
X case 'X':
X *pval = phexnumber(fptr);
X break;
X case '\\':
X *pval = cvfixnum((FIXNUM)xlgetc(fptr));
X break;
X default:
X xlfail("unknown character after #");
X }
X return (TRUE);
X case '`': /* a back quoted expression */
X xlgetc(fptr);
X *pval = pquote(fptr,s_bquote);
X return (TRUE);
X case ',': /* a comma or comma-at expression */
X xlgetc(fptr);
X if (xlpeek(fptr) == '@') {
X xlgetc(fptr);
X *pval = pquote(fptr,s_comat);
X }
X else
X *pval = pquote(fptr,s_comma);
X return (TRUE);
X case '(': /* a sublist */
X *pval = plist(fptr);
X return (TRUE);
X case ')': /* closing paren - shouldn't happen */
X xlfail("extra right paren");
X case '.': /* dot - shouldn't happen */
X xlfail("misplaced dot");
X case ';': /* a comment */
X pcomment(fptr);
X break;
X case '"': /* a string */
X *pval = pstring(fptr);
X return (TRUE);
X default:
X if (issym(ch)) /* a name */
X *pval = pname(fptr);
X else
X xlfail("invalid character");
X return (TRUE);
X }
X}
X
X/* phexnumber - parse a hexidecimal number */
XLOCAL NODE *phexnumber(fptr)
X NODE *fptr;
X{
X long num;
X int ch;
X
X num = 0L;
X while ((ch = xlpeek(fptr)) != EOF) {
X if (islower(ch)) ch = toupper(ch);
X if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
X break;
X xlgetc(fptr);
X num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
X }
X return (cvfixnum((FIXNUM)num));
X}
X
X/* pcomment - parse a comment */
XLOCAL pcomment(fptr)
X NODE *fptr;
X{
X int ch;
X
X /* skip to end of line */
X while ((ch = checkeof(fptr)) != EOF && ch != '\n')
X ;
X}
X
X/* plist - parse a list */
XLOCAL NODE *plist(fptr)
X NODE *fptr;
X{
X NODE *oldstk,val,*lastnptr,*nptr,*p;
X int ch;
X
X /* increment the nesting level */
X xlplevel += 1;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* skip the opening paren */
X xlgetc(fptr);
X
X /* keep appending nodes until a closing paren is found */
X lastnptr = NIL;
X for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
X
X /* check for end of file */
X if (ch == EOF)
X badeof(fptr);
X
X /* check for a dotted pair */
X if (ch == '.') {
X
X /* skip the dot */
X xlgetc(fptr);
X
X /* make sure there's a node */
X if (lastnptr == NIL)
X xlfail("invalid dotted pair");
X
X /* parse the expression after the dot */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplacd(lastnptr,p);
X
X /* make sure its followed by a close paren */
X if (nextch(fptr) != ')')
X xlfail("invalid dotted pair");
X
X /* done with this list */
X break;
X }
X
X /* allocate a new node and link it into the list */
X nptr = newnode(LIST);
X if (lastnptr == NIL)
X val.n_ptr = nptr;
X else
X rplacd(lastnptr,nptr);
X
X /* initialize the new node */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplaca(nptr,p);
X }
X
X /* skip the closing paren */
X xlgetc(fptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* decrement the nesting level */
X xlplevel -= 1;
X
X /* return successfully */
X return (val.n_ptr);
X}
X
X/* pstring - parse a string */
XLOCAL NODE *pstring(fptr)
X NODE *fptr;
X{
X NODE *oldstk,val;
X char sbuf[STRMAX+1];
X int ch,i,d1,d2,d3;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* skip the opening quote */
X xlgetc(fptr);
X
X /* loop looking for a closing quote */
X for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
X switch (ch) {
X case EOF:
X badeof(fptr);
X case '\\':
X switch (ch = checkeof(fptr)) {
X case 'e':
X ch = '\033';
X break;
X case 'n':
X ch = '\n';
X break;
X case 'r':
X ch = '\r';
X break;
X case 't':
X ch = '\t';
X break;
X default:
X if (ch >= '0' && ch <= '7') {
X d1 = ch - '0';
X d2 = checkeof(fptr) - '0';
X d3 = checkeof(fptr) - '0';
X ch = (d1 << 6) + (d2 << 3) + d3;
X }
X break;
X }
X }
X sbuf[i] = ch;
X }
X sbuf[i] = 0;
X
X /* initialize the node */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = strsave(sbuf);
X val.n_ptr->n_strtype = DYNAMIC;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL NODE *pquote(fptr,sym)
X NODE *fptr,*sym;
X{
X NODE *oldstk,val,*p;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* allocate two nodes */
X val.n_ptr = newnode(LIST);
X rplaca(val.n_ptr,sym);
X rplacd(val.n_ptr,newnode(LIST));
X
X /* initialize the second to point to the quoted expression */
X if (!parse(fptr,&p))
X badeof(fptr);
X rplaca(cdr(val.n_ptr),p);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the quoted expression */
X return (val.n_ptr);
X}
X
X/* pname - parse a symbol name */
XLOCAL NODE *pname(fptr)
X NODE *fptr;
X{
X char sname[STRMAX+1];
X NODE *val;
X int ch,i;
X
X /* get symbol name */
X for (i = 0; i < STRMAX && (ch = xlpeek(fptr)) != EOF && issym(ch); ) {
X sname[i++] = (islower(ch) ? toupper(ch) : ch);
X xlgetc(fptr);
X }
X sname[i] = 0;
X
X /* check for a number or enter the symbol into the oblist */
X return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X NODE *fptr;
X{
X int ch;
X
X /* return and save the next non-blank character */
X while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X xlgetc(fptr);
X return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X NODE *fptr;
X{
X int ch;
X
X if ((ch = xlgetc(fptr)) == EOF)
X badeof(fptr);
X return (ch);
X}
X
X/* badeof - unexpected eof */
XLOCAL badeof(fptr)
X NODE *fptr;
X{
X xlgetc(fptr);
X xlfail("unexpected EOF");
X}
X
X/* isnumber - check if this string is a number */
Xint isnumber(str,pval)
X char *str; NODE **pval;
X{
X int dl,dr;
X char *p;
X
X /* initialize */
X p = str; dl = dr = 0;
X
X /* check for a sign */
X if (*p == '+' || *p == '-')
X p++;
X
X /* check for a string of digits */
X while (isdigit(*p))
X p++, dl++;
X
X /* check for a decimal point */
X if (*p == '.') {
X p++;
X while (isdigit(*p))
X p++, dr++;
X }
X
X /* make sure there was at least one digit and this is the end */
X if ((dl == 0 && dr == 0) || *p)
X return (FALSE);
X
X /* convert the string to an integer and return successfully */
X if (*str == '+') ++str;
X if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X *pval = (dr ? cvflonum(FCNV(str)) : cvfixnum(ICNV(str)));
X return (TRUE);
X}
X
X/* issym - check whether a character if valid in a symbol name */
XLOCAL int issym(ch)
X int ch;
X{
X if (ch <= ' ' || ch >= 0177 ||
X ch == '(' ||
X ch == ')' ||
X ch == ';' ||
X ch == ',' ||
X ch == '`' ||
X ch == '"' ||
X ch == '\'')
X return (FALSE);
X else
X return (TRUE);
X}
SHAR_EOF
if test 9377 -ne "`wc -c 'xlread.c'`"
then
echo shar: error transmitting "'xlread.c'" '(should have been 9377 characters)'
fi
echo shar: extracting "'xlstr.c'" '(3152 characters)'
if test -f 'xlstr.c'
then
echo shar: over-writing existing file "'xlstr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstr.c'
X/* xlstr - xlisp string builtin functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack;
X
X/* external procedures */
Xextern char *strcat();
X
X/* xstrcat - concatenate a bunch of strings */
XNODE *xstrcat(args)
X NODE *args;
X{
X NODE *oldstk,val,*p;
X char *str;
X int len;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* find the length of the new string */
X for (p = args, len = 0; p; )
X len += strlen(xlmatch(STR,&p)->n_str);
X
X /* create the result string */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = str = stralloc(len);
X *str = 0;
X
X /* combine the strings */
X while (args)
X strcat(str,xlmatch(STR,&args)->n_str);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* xsubstr - return a substring */
XNODE *xsubstr(args)
X NODE *args;
X{
X NODE *oldstk,arg,src,val;
X int start,forlen,srclen;
X char *srcptr,*dstptr;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&src,&val,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get string and its length */
X src.n_ptr = xlmatch(STR,&arg.n_ptr);
X srcptr = src.n_ptr->n_str;
X srclen = strlen(srcptr);
X
X /* get starting pos -- must be present */
X start = xlmatch(INT,&arg.n_ptr)->n_int;
X
X /* get length -- if not present use remainder of string */
X forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);
X
X /* make sure there aren't any more arguments */
X xllastarg(arg.n_ptr);
X
X /* don't take more than exists */
X if (start + forlen > srclen)
X forlen = srclen - start + 1;
X
X /* if start beyond string -- return null string */
X if (start > srclen) {
X start = 1;
X forlen = 0; }
X
X /* create return node */
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = dstptr = stralloc(forlen);
X
X /* move string */
X for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
X ;
X *dstptr = 0;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the substring */
X return (val.n_ptr);
X}
X
X/* xstring - return a string consisting of a single character */
XNODE *xstring(args)
X NODE *args;
X{
X NODE *oldstk,val;
X char *p;
X int ch;
X
X /* get the character (integer) */
X ch = xlmatch(INT,&args)->n_int;
X xllastarg(args);
X
X /* make a one character string */
X oldstk = xlsave(&val,NULL);
X val.n_ptr = newnode(STR);
X val.n_ptr->n_str = p = stralloc(1);
X *p++ = ch; *p = '\0';
X xlstack = oldstk;
X
X /* return the new string */
X return (val.n_ptr);
X}
X
X/* xchar - extract a character from a string */
XNODE *xchar(args)
X NODE *args;
X{
X char *str;
X int n;
X
X /* get the string and the index */
X str = xlmatch(STR,&args)->n_str;
X n = xlmatch(INT,&args)->n_int;
X xllastarg(args);
X
X /* range check the index */
X if (n < 0 || n >= strlen(str))
X xlerror("index out of range",cvfixnum((FIXNUM)n));
X
X /* return the character */
X return (cvfixnum((FIXNUM)str[n]));
X}
SHAR_EOF
if test 3152 -ne "`wc -c 'xlstr.c'`"
then
echo shar: error transmitting "'xlstr.c'" '(should have been 3152 characters)'
fi
echo shar: extracting "'xlsubr.c'" '(4445 characters)'
if test -f 'xlsubr.c'
then
echo shar: over-writing existing file "'xlsubr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsubr.c'
X/* xlsubr - xlisp builtin function support routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *k_test,*k_tnot,*s_eql;
Xextern NODE *xlstack;
X
X/* xlsubr - define a builtin function */
Xxlsubr(sname,type,subr)
X char *sname; int type; NODE *(*subr)();
X{
X NODE *sym;
X
X /* enter the symbol */
X sym = xlsenter(sname);
X
X /* initialize the value */
X sym->n_symvalue = newnode(type);
X sym->n_symvalue->n_subr = subr;
X}
X
X/* xlarg - get the next argument */
XNODE *xlarg(pargs)
X NODE **pargs;
X{
X NODE *arg;
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X xlfail("too few arguments");
X
X /* get the argument value */
X arg = car(*pargs);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* return the argument */
X return (arg);
X}
X
X/* xlmatch - get an argument and match its type */
XNODE *xlmatch(type,pargs)
X int type; NODE **pargs;
X{
X NODE *arg;
X
X /* get the argument */
X arg = xlarg(pargs);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != LIST)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* return the argument */
X return (arg);
X}
X
X/* xlevarg - get the next argument and evaluate it */
XNODE *xlevarg(pargs)
X NODE **pargs;
X{
X NODE *oldstk,val;
X
X /* create a new stack frame */
X oldstk = xlsave(&val,NULL);
X
X /* get the argument */
X val.n_ptr = xlarg(pargs);
X
X /* evaluate the argument */
X val.n_ptr = xleval(val.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the argument */
X return (val.n_ptr);
X}
X
X/* xlevmatch - get an evaluated argument and match its type */
XNODE *xlevmatch(type,pargs)
X int type; NODE **pargs;
X{
X NODE *arg;
X
X /* get the argument */
X arg = xlevarg(pargs);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != LIST)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* return the argument */
X return (arg);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult,pargs)
X NODE **pfcn; int *ptresult; NODE **pargs;
X{
X NODE *arg;
X
X /* default the argument to eql */
X if (!consp(*pargs)) {
X *pfcn = getvalue(s_eql);
X *ptresult = TRUE;
X return;
X }
X
X /* get the keyword */
X arg = car(*pargs);
X
X /* check the keyword */
X if (arg == k_test)
X *ptresult = TRUE;
X else if (arg == k_tnot)
X *ptresult = FALSE;
X else
X xlfail("expecting :test or :test-not");
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X xlfail("no value for keyword argument");
X
X /* get the argument value */
X *pfcn = car(*pargs);
X
X /* if its a symbol, get its value */
X if (symbolp(*pfcn))
X *pfcn = xleval(*pfcn);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X}
X
X/* xlgetfile - get a file or stream */
XNODE *xlgetfile(pargs)
X NODE **pargs;
X{
X NODE *arg;
X
X /* get a file or stream (cons) or nil */
X if (arg = xlarg(pargs)) {
X if (filep(arg)) {
X if (arg->n_fp == NULL)
X xlfail("file not open");
X }
X else if (!consp(arg))
X xlerror("bad argument type",arg);
X }
X return (arg);
X}
X
X/* xllastarg - make sure the remainder of the argument list is empty */
Xxllastarg(args)
X NODE *args;
X{
X if (args)
X xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X NODE *arg1,*arg2;
X{
X return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X NODE *arg1,*arg2;
X{
X if (eq(arg1,arg2))
X return (TRUE);
X else if (fixp(arg1) && fixp(arg2))
X return (arg1->n_int == arg2->n_int);
X else if (floatp(arg1) && floatp(arg2))
X return (arg1->n_float == arg2->n_float);
X else if (stringp(arg1) && stringp(arg2))
X return (strcmp(arg1->n_str,arg2->n_str) == 0);
X else
X return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X NODE *arg1,*arg2;
X{
X /* compare the arguments */
X if (eql(arg1,arg2))
X return (TRUE);
X else if (consp(arg1) && consp(arg2))
X return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
X else
X return (FALSE);
X}
SHAR_EOF
if test 4445 -ne "`wc -c 'xlsubr.c'`"
then
echo shar: error transmitting "'xlsubr.c'" '(should have been 4445 characters)'
fi
echo shar: extracting "'xlsym.c'" '(5794 characters)'
if test -f 'xlsym.c'
then
echo shar: over-writing existing file "'xlsym.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsym.c'
X/* xlsym - symbol handling routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *oblist,*keylist;
Xextern NODE *s_unbound;
Xextern NODE *xlstack;
Xextern NODE *xlenv;
X
X/* forward declarations */
XFORWARD NODE *symenter();
XFORWARD NODE *findprop();
X
X/* xlenter - enter a symbol into the oblist or keylist */
XNODE *xlenter(name,type)
X char *name;
X{
X return (symenter(name,type,(*name == ':' ? keylist : oblist)));
X}
X
X/* symenter - enter a symbol into a package */
XLOCAL NODE *symenter(name,type,listsym)
X char *name; int type; NODE *listsym;
X{
X NODE *oldstk,*lsym,*nsym,newsym;
X int cmp;
X
X /* check for nil */
X if (strcmp(name,"NIL") == 0)
X return (NIL);
X
X /* check for symbol already in table */
X lsym = NIL;
X nsym = getvalue(listsym);
X while (nsym) {
X if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
X break;
X lsym = nsym;
X nsym = cdr(nsym);
X }
X
X /* check to see if we found it */
X if (nsym && cmp == 0)
X return (car(nsym));
X
X /* make a new symbol node and link it into the list */
X oldstk = xlsave(&newsym,NULL);
X newsym.n_ptr = newnode(LIST);
X rplaca(newsym.n_ptr,xlmakesym(name,type));
X rplacd(newsym.n_ptr,nsym);
X if (lsym)
X rplacd(lsym,newsym.n_ptr);
X else
X setvalue(listsym,newsym.n_ptr);
X xlstack = oldstk;
X
X /* return the new symbol */
X return (car(newsym.n_ptr));
X}
X
X/* xlsenter - enter a symbol with a static print name */
XNODE *xlsenter(name)
X char *name;
X{
X return (xlenter(name,STATIC));
X}
X
X/* xlmakesym - make a new symbol node */
XNODE *xlmakesym(name,type)
X char *name;
X{
X NODE *oldstk,sym,*str;
X
X /* create a new stack frame */
X oldstk = xlsave(&sym,NULL);
X
X /* make a new symbol node */
X sym.n_ptr = newnode(SYM);
X setvalue(sym.n_ptr,*name == ':' ? sym.n_ptr : s_unbound);
X sym.n_ptr->n_symplist = newnode(LIST);
X rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
X str->n_str = (type == DYNAMIC ? strsave(name) : name);
X str->n_strtype = type;
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the new symbol node */
X return (sym.n_ptr);
X}
X
X/* xlsymname - return the print name of a symbol */
Xchar *xlsymname(sym)
X NODE *sym;
X{
X return (car(sym->n_symplist)->n_str);
X}
X
X/* xlframe - create a new environment frame */
XNODE *xlframe(env)
X NODE *env;
X{
X NODE *ptr;
X ptr = newnode(LIST);
X rplacd(ptr,env);
X return (ptr);
X}
X
X/* xlbind - bind a value to a symbol */
Xxlbind(sym,val,env)
X NODE *sym,*val,*env;
X{
X NODE *ptr;
X
X /* create a new environment list entry */
X ptr = newnode(LIST);
X rplacd(ptr,car(env));
X rplaca(env,ptr);
X
X /* create a new variable binding */
X rplaca(ptr,newnode(LIST));
X rplaca(car(ptr),sym);
X rplacd(car(ptr),val);
X}
X
X/* xlgetvalue - get the value of a symbol (checked) */
XNODE *xlgetvalue(sym)
X NODE *sym;
X{
X NODE *val;
X while ((val = xlxgetvalue(sym)) == s_unbound)
X xlunbound(sym);
X return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XNODE *xlxgetvalue(sym)
X NODE *sym;
X{
X NODE *val;
X
X /* check for this being an instance variable */
X if (xlobgetvalue(sym,&val))
X return (val);
X
X /* get the value from the environment list or the global value */
X return (xlygetvalue(sym));
X}
X
X/* xlygetvalue - get the value of a symbol (no instance variables) */
XNODE *xlygetvalue(sym)
X NODE *sym;
X{
X NODE *fp,*ep;
X
X /* check the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X for (ep = car(fp); ep; ep = cdr(ep))
X if (sym == car(car(ep)))
X return (cdr(car(ep)));
X
X /* return the global value */
X return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X NODE *sym,*val;
X{
X NODE *fp,*ep;
X
X /* check for this being an instance variable */
X if (xlobsetvalue(sym,val))
X return;
X
X /* look for the symbol in the environment list */
X for (fp = xlenv; fp; fp = cdr(fp))
X for (ep = car(fp); ep; ep = cdr(ep))
X if (sym == car(car(ep))) {
X rplacd(car(ep),val);
X return;
X }
X
X /* store the global value */
X setvalue(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XNODE *xlgetprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *p;
X return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X NODE *sym,*val,*prp;
X{
X NODE *oldstk,p,*pair;
X if ((pair = findprop(sym,prp)) == NIL) {
X oldstk = xlsave(&p,NULL);
X p.n_ptr = newnode(LIST);
X rplaca(p.n_ptr,prp);
X rplacd(p.n_ptr,pair = newnode(LIST));
X rplaca(pair,val);
X rplacd(pair,cdr(sym->n_symplist));
X rplacd(sym->n_symplist,p.n_ptr);
X xlstack = oldstk;
X }
X rplaca(pair,val);
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *last,*p;
X last = NIL;
X for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
X if (car(p) == prp)
X if (last)
X rplacd(last,cdr(cdr(p)));
X else
X rplacd(sym->n_symplist,cdr(cdr(p)));
X last = cdr(p);
X }
X}
X
X/* findprop - find a property pair */
XLOCAL NODE *findprop(sym,prp)
X NODE *sym,*prp;
X{
X NODE *p;
X for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X if (car(p) == prp)
X return (cdr(p));
X return (NIL);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X /* initialize the oblist */
X oblist = xlmakesym("*OBLIST*",STATIC);
X setvalue(oblist,newnode(LIST));
X rplaca(getvalue(oblist),oblist);
X
X /* initialize the keyword list */
X keylist = xlsenter("*KEYLIST*");
X
X /* enter the unbound symbol indicator */
X s_unbound = xlsenter("*UNBOUND*");
X setvalue(s_unbound,s_unbound);
X}
SHAR_EOF
if test 5794 -ne "`wc -c 'xlsym.c'`"
then
echo shar: error transmitting "'xlsym.c'" '(should have been 5794 characters)'
fi
echo shar: extracting "'xlsys.c'" '(3738 characters)'
if test -f 'xlsys.c'
then
echo shar: over-writing existing file "'xlsys.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsys.c'
X/* xlsys.c - xlisp builtin system functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern NODE *xlstack,*xlenv;
Xextern int anodes;
X
X/* external symbols */
Xextern NODE *a_subr,*a_fsubr;
Xextern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
Xextern NODE *true;
X
X/* xload - direct input from a file */
XNODE *xload(args)
X NODE *args;
X{
X NODE *oldstk,fname,*val;
X int vflag,pflag;
X
X /* create a new stack frame */
X oldstk = xlsave(&fname,NULL);
X
X /* get the file name, verbose flag and print flag */
X fname.n_ptr = xlmatch(STR,&args);
X vflag = (args ? xlarg(&args) != NIL : TRUE);
X pflag = (args ? xlarg(&args) != NIL : FALSE);
X xllastarg(args);
X
X /* load the file */
X val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the status */
X return (val);
X}
X
X/* xgc - xlisp function to force garbage collection */
XNODE *xgc(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* garbage collect */
X gc();
X
X /* return nil */
X return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XNODE *xexpand(args)
X NODE *args;
X{
X int n,i;
X
X /* get the new number to allocate */
X n = (args ? xlmatch(INT,&args)->n_int : 1);
X xllastarg(args);
X
X /* allocate more segments */
X for (i = 0; i < n; i++)
X if (!addseg())
X break;
X
X /* return the number of segments added */
X return (cvfixnum((FIXNUM)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XNODE *xalloc(args)
X NODE *args;
X{
X int n,oldn;
X
X /* get the new number to allocate */
X n = xlmatch(INT,&args)->n_int;
X
X /* make sure there aren't any more arguments */
X xllastarg(args);
X
X /* set the new number of nodes to allocate */
X oldn = anodes;
X anodes = n;
X
X /* return the old number */
X return (cvfixnum((FIXNUM)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XNODE *xmem(args)
X NODE *args;
X{
X /* make sure there aren't any arguments */
X xllastarg(args);
X
X /* print the statistics */
X stats();
X
X /* return nil */
X return (NIL);
X}
X
X/* xtype - return type of a thing */
XNODE *xtype(args)
X NODE *args;
X{
X NODE *arg;
X
X if (!(arg = xlarg(&args)))
X return (NIL);
X
X switch (ntype(arg)) {
X case SUBR: return (a_subr);
X case FSUBR: return (a_fsubr);
X case LIST: return (a_list);
X case SYM: return (a_sym);
X case INT: return (a_int);
X case FLOAT: return (a_float);
X case STR: return (a_str);
X case OBJ: return (a_obj);
X case FPTR: return (a_fptr);
X default: xlfail("bad node type");
X }
X}
X
X/* xbaktrace - print the trace back stack */
XNODE *xbaktrace(args)
X NODE *args;
X{
X int n;
X
X n = (args ? xlmatch(INT,&args)->n_int : -1);
X xllastarg(args);
X xlbaktrace(n);
X return (NIL);
X}
X
X/* xexit - get out of xlisp */
XNODE *xexit(args)
X NODE *args;
X{
X xllastarg(args);
X exit();
X}
X
X/* xpeek - peek at a location in 68000 memory */
XNODE *xpeek(args)
X NODE *args;
X{
X int *adr;
X adr = (int *)xlmatch(INT,&args)->n_int;
X xllastarg(args);
X return (cvfixnum((FIXNUM)*adr));
X}
X
X/* xpoke - poke a location in 68000 memory */
XNODE *xpoke(args)
X NODE *args;
X{
X NODE *val;
X int *adr;
X adr = (int *)xlmatch(INT,&args)->n_int;
X val = xlmatch(INT,&args);
X xllastarg(args);
X *adr = val->n_int;
X return (val);
X}
X
X/* xaddressof - return the address of an XLISP node */
XNODE *xaddressof(args)
X NODE *args;
X{
X NODE *node;
X node = xlarg(&args);
X xllastarg(args);
X return (cvfixnum((FIXNUM)node));
X}
SHAR_EOF
if test 3738 -ne "`wc -c 'xlsys.c'`"
then
echo shar: error transmitting "'xlsys.c'" '(should have been 3738 characters)'
fi
# End of shell archive
exit 0
--
Jwahar R. Bammi
Usenet: .....!decvax!cwruecmp!bammi
CSnet: bammi@case
Arpa: bammi%case@csnet-relay
CompuServe: 71515,155