stergios@rocky.UUCP (06/08/87)
Heres a very rough version of forth i wrote in common lisp for a course
this past quarter. Its functional, but not complete. I'm throwing
this out to the net thinking some would like to play with it. Go ahead
and make all the changes you like, cause I'll probably never look at this
again. I've added some sparse notes in the source just for the heck of it.
If you get the urge to, praise, ask questions, flame (in that order)
my addresses are:
(during the school year)
% UUCP: !decwrl!rocky.stanford.edu!stergios %
% ARPA: f.flex@othello.stanford.edu %
% USnail: Crothers Memorial #690, Stanford, CA. 94305 %
% Pa Bell: (415) 326-9051 %
(in the summer time)
% UUCP: !rice!soma!sisd!nasa-jcs!cleghorn %
% ARPA: "cleghorn%aio.span@star.stanford.edu" %
% USnail: Nasa Johnson Space Center, Mail Code FM 72, %
% Houston, Tx. 77058 %
With out further adue, I'll make my disclaimer and let this rip!
Use this code at your own risk. It's not any good, It failed all
tests, and you'd be better off using a TI 35 hand-held!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STERGIOS MARINOPOULOS ;;;
;;; CS 022 LISP PROJECT ;;;
;;; FORTH11.LSP ;;;
;;; ORIGINAL (FORTH1.LSP) CREATED THURSDAY 1 APRIL ;;;
;;; CREATED SUNDAY 31 MAY ;;;
;;; MODIFIED SUNDAY 7 JUNE ;;;
;;; TOTAL ESTIMATED TIME: 45 hr. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; THIS IS A FORTH INTERPRETER WRITTEN IN LISP NO LESS. ;;;
;;; TO RUN THIS VERSION OF LISP JUST LOAD THIS FILE INTO YOUR FAVORITE ;;;
;;; VERSION OF COMMON LISP (WITH CONFIDENCE, AND YOUR FAVORITE ;;;
;;; CAFFINATED DRINK (OR WHAT EVER DOES THE TRICK) OFCOURSE!) AND INVOKE ;;;
;;; THE FORTH INTERPRETER BY THE FOLLOWING MAGIC COMMAND: ;;;
;;; ;;;
;;; (forth) <cr> ;;;
;;; ;;;
;;; AND YOU'LL BE OFF AND RUNNING (TO WHERE IS YOUR CHOICE). ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; YOU WILL NOTICE SOME (READ A LOT) DIFFERENCES IN SYNTAX (MAINLY STANDARD;;;
;;; WORD NAMES) AND THE LEVEL OF NESTING ALLOWED OF DO LOOPS AND IF THEN ;;;
;;; ELSE CLAUSES; PRIMARILY THAT YOU CAN'T! THOUGH YOU CAN HAVE ONE WITHIN ;;;
;;; THE OTHER, SELF NESTING IS NOT ALLOWED (THOGUH IT WOULD BE TRIVAL TO ;;;
;;; TO IMPLEMENT -=> AND EXTRA AUX FUNCTION SHOULD DO THE TRICK IN EACH ;;;
;;; CASE) ;;;
;;; THE CODE IS PRETTY MUCH SELF DOCUMENTING, BUT I'LL LIST THE MAJOR DIFF'S;;;
;;; HERE: ;;;
;;; REGULAR-NAME MYNAME ;;;
;;; : { ;;;
;;; ; } ;;;
;;; < << ;;;
;;; > >> ;;;
;;; = == ;;;
;;; . DOT ;;;
;;; .S DOTS ;;;
;;; ;;;
;;; NOTES: ;;;
;;; 1) AN if MUST ALWAYS HAVE AN ASSOCIATED else CLAUSE ;;;
;;; { TEST 1 1 == IF "TRUE" DOT ELSE "FLASE" DOT THEN } ;;;
;;; 2) NOTICE YOU CAN PLACE ANY THING IN THE WORLD ON THE STACK; ;;;
;;; integers, floating point, strings, (the beauty of lisp) ;;;
;;; 3) THIS IS A PRETTY MINIMAL IMPLEMENTATION, IF YOU WANT TO ADD ;;;
;;; MORE STANDARD FORTH WORDS DEFUN A FUNCTION BY THE SAME ;;;
;;; NAME AND ALSO PUT THE NAME IN THE GLOBAL VARIABLE *fwords* ;;;
;;; 4) VERY LITTLE ERROR CHECKING IS PERFORMED ;;;
;;; 5) SPEED WAS NOT AN IMPORTANT ISSUE. (JUST REPLACE SOME FUNCTIONS ;;;
;;; WITH MACROS TO HELP SPEED THINGS UP. I ALREADY DID TO THE ;;;
;;; MOST OFTEN USED FUNCTIONS: (pop-satck), (push-stack item) ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GLOBAL VARIABLES ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A LIST OF EXECUTABLE FORTH WORDS
(defvar *fwords* '(dot dup swap forth-cold stack-cold cold drop !
@ dots forget variable create i >r <r
spaces == << >> )
" *fwords* is a special variable that contains a list of all
internally defined executable forth words.")
;;; A LIST OF NON-EXECUTABLE SPECIAL FORTH WORDS
(defvar *sfwords* '(do loop if then else )
" *sfwords* is a special variable that contains a list of all
internally defined non-executable forth words.")
;;; AN ASSCOIATION LIST OF USER WORDS
(defvar *uwords* '(())
" *uwords* is an asscoiation list of user defined words with the
word name as the key, and the definition as the data.")
;;; FORTH MAIN STACK IS A LIST
(defvar *stack* '(())
" *stack* is a simple list that simulates the last in first out
stack that all forths are based on.")
;;; MAIN STACK DEPTH
(defvar *sdepth* '0
" *sdepth* is a special variable that holds the current depth of
the stack.")
;;; FORTH RETURN STACK IS A LIST
(defvar *return-stack* '(())
" *return-stack* is a simple list that simulates the last in first out
return stack that all forths use as a special purpose
stack.")
;;; RETURN STACK DEPTH
(defvar *rdepth* '0
" *rdepth* is a special variable that holds the current depth of the
return stack.")
;;; EXPRESSION UNDERSTOOD VARIABLE
(defvar *understand* 'nil
" *understand* is a special variable that is either true or false depending
on the succesfull parsing of the current token.")
;;; ALLOWABLE MATH OPERATORS ARE STORED IN THIS LIST
(defvar *math* '(+ - * /)
" *math* is a special variable that holds a list of the allowable
forth math opertaors.")
;;; VARIABLE ARE REPRESENTED AS AN ASSOCIATION LIST
(defvar *vars* '((() ()))
" *vars* is a special variable that holds an association list
with the variable name as the key and the value as the
dtat.")
;;; ARRAY OF PIONTERS TO USER DEFINED ARRAYS
(defvar *arrays* (make-array 10) ; CAN MAKE TO ANY SIZE!
" *arrays* is a special variable thats holds a list of pointers
to user defined arrays.")
;;; NUMBER OF USER DEFINED ARRAYS
(defvar *num-arrays* '0
" *num-arrays* is a special variable that contains the number of user defined
arrays.")
;;; NAMES OF USER DEFINED ARRAYS
(defvar *array-names* '()
" *array-names* is a simple list contaning the names of user
defined arrays.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MACROS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The following macros all have a similar expansion form:
;;;
;;; (progn
;;; (incf-or-decf *depth*)
;;; (push-or-pop [ITEM] *stack*)) --- where [ITEM] is only for pushing
;;;
;;;
;;; CALLING EXAMPLE: (setf VAR (pop-stack)) -or-
;;; (push-stack ITEM)
;;;
;;; THE RETURNING VALUE IS ONLY IMPORTANT WITH THE POP MACROS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MACRO TO PUSH OBJECT ON TO MAIN STACK.
(defmacro push-stack (num)
" macro to push a number on to the main forth stack"
(list 'progn
(list 'push num '*stack*)
(list 'incf '*sdepth*)))
;;; MACRO TO PUSH ONJECT ON TO RETURN STACK
(defmacro push-return-stack (num)
" macro to push a number on to the return stack"
(list 'progn
(list 'push num '*return-stack*)
(list 'incf '*rdepth*)))
;;; MACRO TO POP OBJECT FROM MAIN STACK
(defmacro pop-stack ()
" macro to pop a number from the main forth stack"
(list 'progn
(list 'decf '*sdepth*)
(list 'pop '*stack*)))
;;; MACRO TO POP OBJECT FROM RETURN STACK
(defmacro pop-return-stack ()
" macro to pop a number from the return-stack"
(list 'progn
(list 'decf '*rdepth*)
(list 'pop '*return-stack*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STARTUP FUNCTION: CALLING FUNCTION FROM LISP - ELSE NEVER USED
;;;
;;; CALLING EXAMPLE: (forth) --- {only from lisp}
;;; RETURNS: never returns --- {except back to lisp}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun forth ()
" forth this function is the calling procedure from lisp
to envoke the forth interpreter."
;;; FOR KCL THIS INITIAL PRINTING IS REQUIRED -
;;; FOR CLISP IT IS NOT????????
(format t "~%FORTH> ")
(print-eval))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAINFUNCTION: INTERPRETER / EVALUATOR FUNCTION
;;; THE PRINT-EVAL ROUTINE IS IN ESSENCE THE FORTH LISTERNER, VERY SIMILAR
;;; (AT LEAST CONCEPTUALLY) TO THE LISP LISTERNER.
;;;
;;; CALLING EXAMPLE: (print-eval)
;;; RETURNS: nothing important
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun print-eval ()
" print-eval this function is the forth listener, very much like
a lisp listener."
;;; PEEK IN INPUT STREAM - IF USER TYPED AHEAD DO NOT PRINT "FORTH"
(if (not (listen t)) (format t "FORTH> "))
(setf token (read t))
(cond
;;; ACT ON THE TOKEN MOST RECENTLY READ ACCORDING TO ITS TYPE
;;; AND THEN ITTERATE ON THIS FUNCTION (ITS NOT REALLY RECURSION)
((nump token) (push-stack token) (print-eval))
((mathp token) (do-math token) (print-eval))
((varp token) (push-stack token) (print-eval))
((stringp token) (push-stack token) (print-eval))
((arayp token) (push-stack token) (print-eval))
((new-uwordp token) (fcompile) (print-eval))
((fwordp token) (do-fword token) (print-eval))
((uwordp token) (do-uword token) (print-eval))
((equal token 'bye) (format t "~% BYE BYE ~%"))
((not *understand*) (format t "~% ~s .... What? ~%" token)
(print-eval))
(t (print-eval))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FORTH PREDICATES: THESE FUNCTIONS ARE TESTS FOR DETERMINING THE WHAT
;;; TYPE OF OBJECT THE ARGUMENT IS, AND THEY SET A VARIABLE "UNDERSTAND"
;;; ACCORDINGLY FOR USE BY THE PRINT-EVAL ROUTINE
;;;
;;; CALLING EXAMPLE: (predicate token) --- {for all predicates}
;;; RETURNS: T or NIL depending on the test results
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(format t " LOADING PREDICATES~% ")
;;; IS THE TOKEN A NUMBER?
(defun nump (num)
" is the arg a number?"
(if (numberp num)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS THE ARG A MATH OPERATOR?
(defun mathp (op)
" is the arg a math operator?"
(if (some #'(lambda (x) (equal op x)) *math*)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS THE ARG A FORTH VARIABLE?
(defun varp (varname)
" is the arg a forth variable?"
(if (assoc varname *vars*)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IF THE ARG A FORTH ARRAY"
(defun arayp (name)
" is the arg a forth array?"
(if (get name 'array)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS USER DEFINING A NEW USER WORD?
(defun new-uwordp (def)
" is the user defining a new word?"
(if (equal def '{)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS TOKEN AN EXECUTABLE FORTH WORD?
(defun fwordp (word)
" is the arg an executable forth word?"
(if (some #'(lambda (x) (equal word x)) *fwords*)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS TOKEN A NONEXECUTABLE FORTH WORD?
(defun sfwordp (word)
" is the arg a special forth word / non-executable word?"
(if (some #'(lambda (x) (equal word x)) *sfwords*)
(setf *understand* 't)
(setf *understand* 'nil)))
;;; IS TOKEN A USER DEFINED WORD?
(defun uwordp (word)
" is the arg a user defined forth word?"
(if (assoc word *uwords*)
(setf *understand* 't)
(setf *understand* 'nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DEPTHP CHECKS IF THE DEPTH OF THE STACK IS GREATER THAN THE ARGUMENT
;;; SUPPLIED
;;;
;;; CALLING EXAMPLE: (depthp number)
;;; RETURNS: t, nill accordingly
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun depthp (deep)
(if (not (> *sdepth* deep))
(progn
(stack-cold)
(format t "~%...Stack not deep enough~%")
())
t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INTERNAL FORTH FUNCTIONS:
;;;
;;; THESE FUNCTIONS WILL ONLY BE CALLED FROM WITHIN THIS SOURCE FILE.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(format t "LOADING FORTH INTENRAL FUNCTIONS ~%")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO-MATH TAKES THE TOP TWO ELEMENTS OFF THE MAIN STACK SEES IF THEY
;;; ARE NUMBERS AND IF SO FUNCALLS THE PROPER OPERATOR BY ARGUMENT OP
;;; PLACING THE RESULT ON TOP OF THE STACK
;;;
;;; CALLING EXAMPLE: (do-math op)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-math (op)
(if (depthp 1)
(let*
((top (pop-stack)) (next (pop-stack)))
(if (and (numberp top) (numberp next))
(push-stack (funcall op next top))
(progn
(format t "~% Stack elements not numbers.~%")
(stack-cold))))
(progn
(format t "~%...Stack not deep enough~%")
(stack-cold))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; START BUILDING A FORTH WORD
;;; AN OPENING BRACE HAS BEEN DETECTED SO TAKE OVER INTO THE INPUT STREAM
;;; AND RECORD THE STREAM IN A NEW ENTRY OF THE *UWORDS* ALIST UNTIL A
;;; CLOSING BRACE IS DETECTED
;;;
;;; CALLING EXAMPLE: (fcompile)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fcompile ()
(let* ((word-name (read t))
(exists (assoc word-name *uwords*)))
(setf *uwords* (acons word-name (fcompile-aux 'nil) *uwords*))
(if (consp exists)
(format t "~% Redefined ~S.~%" word-name))
(if (not (verify-word word-name (cdar *uwords*)))
(setf *uwords* (cdr *uwords*)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BUILD THE FORTH WORD
;;; THE WORK HORSE OF FCOMPILE: THIS ACTUALLY DOES MOST OF FCOMPILE'S
;;; WORK EXCEPT FOR ERROR CHECKING
;;;
;;; CALLING EXAMPLE: (fcompile-aux (stream-so-far))
;;; RETURNS: THE STREAM UP TO A "}"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fcompile-aux (l)
(let ((next-word (cons (read t) nil)))
(cond
((equal (car next-word) '}) l)
(t (fcompile-aux (append l next-word))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VERIFY-WORD LOOKS AT A NEWLY DEFINED USER WORD AND CHECKS TO SEE
;;; IF EACH INTERNAL WORD IS A VALID FORTH OBJECT/WORD/UWORD/ETC.
;;;
;;; CALLING EXAMPLE: (verify-word word-name word-definition)
;;; RETURNS: t or nil accordingly
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun verify-word (new-word list)
(let ((curr-word (car list)))
(if (equal curr-word 'nil)
t
(cond
((or (nump curr-word) ; IF ANY ARE TRUE DO THIS -+
(mathp curr-word) ; |
(varp curr-word) ; +------------------------+
(fwordp curr-word) ; |
(sfwordp curr-word) ; |
(stringp curr-word) ; |
(arayp curr-word) ; V
(uwordp curr-word)) (and (verify-word new-word (cdr list))))
(t (progn
(format t "~% Token ~S is undefined in word ~S.~%"
curr-word new-word)
()))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO THE FORTH WORD IN THE STREAM / USER WORD BEING EXECUTED
;;;
;;; CALLING EXAMPLE: (do-fword ford)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-fword (word)
(funcall word))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO-UWORD CONTROLS THE EXECUTION OF A USER DEFINED FORTH WORD
;;; IT FIRST FINDS THE DEFINITION OF THE NAME AND PASSES IT TO
;;; A HELPING FUNCTION
;;;
;;; CALLING EXAMPLE: (do-uword word-name)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-uword (word) ; A USER WORD IS IN THE STREAM
(let ((this-word (assoc word *uwords*)))
(do-uword-aux (cdr this-word))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO-UWORD-AUX ACTUALLY EXECUTES THE FORTH WORD ONCE IT IS PASSED
;;; THE FORTH WORD DEFINITION LIST. IT CDRS DOWN
;;; THE DEFINITION LIST EXECUTING THE CAR UPON EACH CALL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-uword-aux (these-words)
(let ((curr-word (car these-words))
(rest-words (cdr these-words))
(done nil))
(if (equal curr-word 'nil)
(setf done t)
(cond
((nump curr-word) (push-stack curr-word))
((mathp curr-word) (do-math curr-word))
((varp curr-word) (push-stack curr-word))
((uwordp curr-word) (do-uword curr-word))
((fwordp curr-word) (do-fword curr-word))
((stringp curr-word) (push-stack curr-word))
((arayp curr-word) (push-stack curr-word))
((equal curr-word 'do)
(progn
(do-do (get-dowords rest-words))
(setf rest-words (cdr (member 'loop rest-words)))))
((equal curr-word 'if)
(setf rest-words (get-ifwords these-words)))
(t (format t "~% ERROR IN WORD DEFINITION: ~S ~%" curr-word))))
(if (not done)
(do-uword-aux rest-words))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GET-IFWORDS FINDS THE WORDS THAT ARE WITHIN THE "if ... else ... then
;;; CONSTRUCT DEPENDING ON THE TEST VALUE THAT OCCURED BEFORE HAND
;;;
;;; CALLING EXAMPLE: (get-ifwords words-being-executed)
;;; RETURNS: a modified list of words to be executed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-ifwords (words)
(let* ((flag (pop-stack)))
(if (= flag 0)
(get-ifwords-aux words 'else)
(get-ifwords-aux words 'then))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GET-IFOWRDS-AUX IS PASSED A MARK AND A LIST OF WORDS THAT CONTAINS
;;; THE IF ... ELSE ... THEN AND EXTRACTS THE WORDS TO BE EXECUTED
;;; DEPENDING ON THE VALUE OF THE MARK.
;;;
;;; CALLING EXAMPLE: (get-ifwords-aux words mark)
;;; RETURNS: a modified list of words to be executed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-ifwords-aux (words mark)
(let ((rest (cdr (member 'then words)))
(ifwords (cdr (member 'then (reverse (cdr words))))))
(cond
((equal mark 'then)
(append (reverse (cdr (member 'else ifwords))) rest))
((equal mark 'else)
(append (cdr (member 'else (reverse ifwords))) rest)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GET-DOWORDS EXTRACTS THE WORDS WITHIN A do ... loop CONSTUCT THAT
;;; WILL GET EXECUTED A NUMBER OD TIMES
;;;
;;; CALLING EXAMPLE: (get-dowords list-of-words-being-executed)
;;; RETURNS: a list of words within a do ... loop construct
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-dowords (list)
(cond
((equal (car list) 'loop) nil)
(t (cons (car list) (get-dowords (cdr list))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO-DO CONTOLS THE EXECUTION OF THE WORDS WITHIN A do ... loop CONSTRUCT
;;;
;;; CALLING EXAMPLE: (do-do do-words)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-do (do-these-words)
(let* ((from (pop-stack))
(to (pop-stack))
(safe 'nil))
(do ((i from (+ i 1)))
((= i to))
(push-return-stack i)
(do-uword-aux do-these-words)
(setf safe (pop-return-stack)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STANDARD FORTH FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(format t " LOADING FORTH WORDS~%" )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DOT PRINTS THE CURRENT ITEM ON TOP OF THE STACK
;;;
;;; CALLING EXAMPLE: (dot) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dot ()
(if (depthp 0)
(format t " ~s ~%" (pop-stack))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DUP DUPLICATES THE ITEM ON TOP OF THE STACK
;;;
;;; CALLING EXAMPLE: (dup) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dup ()
(if (depthp 0)
(let ((temp (pop-stack)))
(push-stack temp)
(push-stack temp))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SWAP SWAPS THE POSITIONS OF TOP OF THE STACK AND AND THE ITEM UNDERNEATH
;;;
;;; CALLING EXAMPLE: (swap) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun swap ()
(if (depthp 1)
(let*
((top (pop-stack)) (next (pop-stack)))
(push-stack top)
(push-stack next))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FORTH-COLD RESETS THE STATE OF ALL VARIABLE TYPES
;;;
;;; CALLING EXAMPLE: (forth-cold) --- mostly gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun forth-cold () ; RESET FORTH'S INTERNAL STATE
(mapcar #'(lambda (ray) (setf (get ray 'array) 'nil)) *array-names*)
(setf *vars* '((() ())) )
(setf *uwords* '(()))
(setf *arrays* (make-array 10))
(setf *num-arrays* '0)
(setf *array-names* '()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STACK-COLD REMOVES ALL ELEMENTS OF THE MAIN STACK
;;;
;;; CALLING EXAMPLE: (stack-cold) --- mostly gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun stack-cold ()
(setf *stack* '(()))
(setf *sdepth* 0)
(setf *return-stack* '(()))
(setf *rdepth* 0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; COLD RESETS THE ENTIRE INTERNAL STATE OF FORTH
;;;
;;; CALLING EXAMPLE: (cold) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cold ()
(stack-cold)
(forth-cold))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DROP REMOVES THE TOP OF THE MAIN STACK
;;;
;;; CALLING EXAMPLE: (drop) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun drop ()
(pop-stack))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ! STORES THE SECOND ELEMENT ON THE STACK AT THE ADDRES ON TOP OF THE STACK
;;;
;;; CALLING EXAMPLE: (!) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ! ()
(let* ((name (pop-stack)))
(cond
((get name 'var)
(rplacd (assoc name *vars*) (pop-stack)))
((get name 'array)
(setf (aref (aref *arrays* (get name 'pointer))
(pop-stack))
(pop-stack)))
(t (format t "No such variable/array ~S.~%" name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; @ TAKES THE A POINTER OF THE TOP OF THE STACK AND FETCHES THE VALUE
;;; STORED BACK TO THE TOP OF THE STACK
;;;
;;; CALLING EXAMPLE: (@) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun @ ()
(let* ((name (pop-stack)))
(cond
((get name 'var)
(push-stack (cdr (assoc name *vars*))))
((get name 'array)
(push-stack (aref (aref *arrays* (get name 'pointer))
(pop-stack))))
(t (format t "No such variable/array ~S.~%" name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DOTS PRINTS OUT THE ENTIRE SATCK WITH OUT DESTROYING IT
;;;
;;; CALLING EXAMPLE: (dots) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dots ()
(dots-aux *stack*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DOTS-AUX DOES THE DIRTY WORK FOR DOTS
;;;
;;; CALLING EXAMPLE: (dots-aux list-of-the-satck)
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dots-aux (l)
(cond
((eq (car l) nil) nil) ; ; THE *STACK* IS NIL TERMINATED !!
(t (progn
(format t "~s~%" (car l))
(dots-aux (cdr l))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FORGET REMOVES A PREVIOUSLY DEFINED USER-WORD
;;;
;;; CALLING EXAMPLE: (forget) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun forget ()
(let* ((forget-thisword (read t))
(exists (assoc forget-thisword *uwords*)))
(if (consp exists)
(setf *uwords* (forget-aux forget-thisword *uwords*))
(format t "~% ~S does not exist.~%" forget-thisword))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FORGET-AUX ACTUALLY REMOVES THE USER-WORD (AND ALL USER-WORDS DEFINED
;;; AFTER IT) IF IT EXISTS
;;;
;;; CALLING EXAMPLE: (forget key alist-of-user-words)
;;; RETURNS: new alist of user-word
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun forget-aux (key list)
(cond
((equal key (caar list)) (cdr list))
(t (forget-aux key (cdr list)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VARIABLE CREATES A NEW VARIABLE
;;;
;;; CALLING EXAMPLE: (variable) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun variable ()
(let ((name (read t)))
(setf *vars* (acons name 0 *vars*))
(setf (get name 'var) 't)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CREATE DEFINES A NEW ARRAY DESIRED BY THE USER
;;;
;;; CALLING EXAMPLE: (create) --- only gets funcall'ed by the user
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create ()
(let* ((name (read t))
(num (read t))
(key (read t)))
(if (and (numberp num) (equal key 'allot))
(progn
(setf (get name 'pointer) *num-arrays*)
(setf (get name 'array) 't)
(setf *array-names* (cons name *array-names*))
(setf (aref *arrays* *num-arrays*) (make-array num))
(incf *num-arrays*))
(format t "~% Bad array declaration syntax.~%"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I PLACES THE CURRENT COUNT OF THE ITERATION COUNT FROM THE TOP
;;; OF THE RETURN STACK TO THE TOP OF THE MAIN STACK
;;;
;;; CALLING EXAMPLE: (i) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun i ()
(let ((num (pop-return-stack)))
(push-stack num)
(push-return-stack num)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; >R PLACES AN ITEM FROM THE TOP OF THE MAIN STACK TO THE TOP OF THE
;;; RETURN STACK
;;;
;;; CALLING EXAMPLE: (>r) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun >r ()
(push-return-stack (pop-stack)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; <R PLACES AN ITEM FROM THE TOP OF THE RETURN STACK TO THE TOP OF THE
;;; MAIN STACK
;;;
;;; CALLING EXAMPLE: (<r) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun <r ()
(push-stack (pop-return-stack)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SPACES TAKES THE NUMBER OFF THE TOP OF THE STACK AND PRINTS OUT
;;; TO THE TERMINAL THAT NUMBER OF SPACES
;;;
;;; CALLING EXAMPLE: (spaces) --- only gets funcall'ed
;;; RETURNS: NOTHING IMPORTANT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun spaces ()
(format t "~S" (make-string (pop-stack))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; >> TAKES THE TOP TWO ITEMS ON THE STACK AND SEES IF THE SECOND
;;; IS GREATER THAN THE FIRST
;;;
;;; CALLING EXAMPLE: (>>) --- only gets funcall'ed
;;; RETURNS: t or nil
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun >> ()
(let* ((top (pop-stack))
(second (pop-stack)))
(if (> second top)
(push-stack 1)
(push-stack 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; << TAKES THE TOP TWO ITEMS OF THE STACK AND SEES IF THE SECOND IS
;;; LESS THAN THE TOP
;;;
;;; CALLING EXAMPLE: (<<) --- only gets funcall'ed
;;; RETURNS: t or nil
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun << ()
(let* ((top (pop-stack))
(second (pop-stack)))
(if (< second top)
(push-stack 1)
(push-stack 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; == SEES IF THE TOP TWO ITEMS ON THE STACK ARE EQUAL
;;;
;;; CALLING EXAMPLE: (==) --- only gets funcall'ed
;;; RETURNS: t or nil
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun == ()
(let* ((top (pop-stack))
(second (pop-stack)))
(if (= second top)
(push-stack 1)
(push-stack 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SET THE FUNCTION POINTERS OF THE FOLLOWING SYMBOLS AS NEEDED BY THE
;;; NEW DEFINTIONS FORTH REQUIRES (SEE ABOVE FOR ACTUAL DEF'S)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setf (symbol-function '\+) #'+)
(setf (symbol-function '\-) #'-)
(setf (symbol-function '\*) #'*)
(setf (symbol-function '\/) #'/)
--
% UUCP: !decwrl!rocky.stanford.edu!stergios %
% ARPA: f.flex@othello.stanford.edu %
% USnail: Crothers Memorial #690, Stanford, CA. 94305 %
% Pa Bell: (415) 326-9051 %