* interp/lexing.boot: New.

	* interp/metalex.lisp: Include it.  Use new stack datatype support.
	* interp/parsing.lisp: Use new stack datatype support.
	* interp/Makefile.in: Adjust.

5 files changed, 125 insertions, 68 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index e834c58e..8c11fae0 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2011-10-04  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/lexing.boot: New.
+	* interp/metalex.lisp: Include it.  Use new stack datatype support.
+	* interp/parsing.lisp: Use new stack datatype support.
+	* interp/Makefile.in: Adjust.
+
 2011-10-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* boot/utility.boot (symbolAssoc): Rename from assocSymbol. Export.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 2377686c..79e21ea0 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -56,7 +56,8 @@ OBJS=   boot-pkg.$(FASLEXT)	types.$(FASLEXT)	 \
 	hash.$(FASLEXT) 	lisp-backend.$(FASLEXT)	 \
 	sys-globals.$(FASLEXT)	vmlisp.$(FASLEXT)	 \
 	                    	sys-os.$(FASLEXT)	 \
-	sys-utility.$(FASLEXT)  diagnostics.$(FASLEXT)	 \
+	sys-utility.$(FASLEXT)  lexing.$(FASLEXT)        \
+	diagnostics.$(FASLEXT)	                         \
 	union.$(FASLEXT)	sys-macros.$(FASLEXT)	 \
 	macros.$(FASLEXT)	metalex.$(FASLEXT)	 \
 	parsing.$(FASLEXT)	util.$(FASLEXT)		 \
@@ -65,7 +66,7 @@ OBJS=   boot-pkg.$(FASLEXT)	types.$(FASLEXT)	 \
 	astr.$(FASLEXT)		bits.$(FASLEXT)		\
 	ht-util.$(FASLEXT)	bc-util.$(FASLEXT)	\
 	br-search.$(FASLEXT)	alql.$(FASLEXT)		\
-	buildom.$(FASLEXT)	                    	\
+	buildom.$(FASLEXT)	                        \
 	simpbool.$(FASLEXT)	g-timer.$(FASLEXT)	\
 	cattable.$(FASLEXT)	posit.$(FASLEXT)	\
 	cformat.$(FASLEXT)	clam.$(FASLEXT)		\
@@ -331,9 +332,10 @@ newaux.$(FASLEXT): macros.$(FASLEXT)
 preparse.$(FASLEXT): fnewmeta.$(FASLEXT)
 fnewmeta.$(FASLEXT): parsing.$(FASLEXT)
 parsing.$(FASLEXT): metalex.$(FASLEXT)
-metalex.$(FASLEXT): macros.$(FASLEXT)
+metalex.$(FASLEXT): lexing.$(FASLEXT) macros.$(FASLEXT)
 nlib.$(FASLEXT): macros.$(FASLEXT)
 macros.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
+lexing.$(FASLEXT): sys-utility.$(FASLEXT)
 
 ## The new parser component roughtly is:
 ##   astr.boot dq.boot incl.boot pile.boot ptrees.boot
diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot
new file mode 100644
index 00000000..506e22c6
--- /dev/null
+++ b/src/interp/lexing.boot
@@ -0,0 +1,88 @@
+-- Copyright (C) 2011, Gabriel Dos Reis.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of OpenAxiom. nor the names of its contributors
+--       may be used to endorse or promote products derived from this
+--       software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+--
+
+--%
+--% Author: Gabriel Dos Reis
+--%
+
+import sys_-utility
+
+namespace BOOT
+
+module lexing
+
+--%
+--% Stack abstract datatype.
+--%  Operational semantics:
+--%     structure Stack ==
+--%         Record(store: List T, size: Integer, top: T, updated?: Boolean)
+
+++ Construct a new stack
+makeStack() ==
+  [nil,0,nil,false]
+
+macro stackStore st ==
+  first st
+
+macro stackSize st ==
+  second st
+
+macro stackTop st ==
+  third st
+
+macro stackUpdated? st ==
+  fourth st
+
+stackLoad!(l,st) ==
+  stackStore(st) := l
+  stackSize(st) := #l
+  stackTop(st) := first l
+
+stackClear! st ==
+  stackStore(st) := nil
+  stackSize(st) := 0
+  stackTop(st) := nil
+  stackUpdate?(st) := false
+
+stackPush!(x,st) ==
+  stackStore(st) := [x,:stackStore st]
+  stackTop(st) := x
+  stackSize(st) := stackSize st + 1
+  stackUpdated?(st) := true
+
+stackPop! st ==
+  y := first stackStore st
+  stackStore(st) := rest stackStore st
+  stackSize(st) := stackSize st - 1
+  if stackStore st ~= nil then
+    stackTop(st) := first stackStore st
+  y
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index 6ba27c7c..4e9c208a 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -42,6 +42,7 @@
 ;               4. META Token Parsing Actions
 ;               5. META Error Handling
 
+(IMPORT-MODULE "lexing") 
 (IMPORT-MODULE "macros") 
 (in-package "BOOT")
 
@@ -55,50 +56,9 @@
 ; 1. Data structure declarations (defstructs) for parsing objects
 ;
 ;               A. Line Buffer
-;               B. Stack
 ;               C. Token
 ;               D. Reduction
 
-; 1B. A Stack (of lines, tokens, or whatever)
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-;       Make-Stack, Stack-Store, Stack-Size, Stack-Top, Stack-Load, Stack-Clear,
-;       Stack-/-Empty, Stack-Push, Stack-Pop
-
-(defstruct Stack                "A stack"
-           (Store nil)          ; contents of the stack
-           (Size 0)             ; number of elements in Store
-           (Top nil)            ; first element of Store
-
-           (Updated nil)        ; whether something has been pushed on the stack
-                                ; since this flag was last set to NIL
-)
-
-(defun stack-load (list stack)
-  (setf (stack-store stack) list
-        (stack-size stack) (length list)
-        (stack-top stack) (car list)))
-
-(defun stack-clear (stack)
-  (setf (stack-store stack) nil (stack-size stack) 0 (stack-top stack) nil
-        (stack-updated stack) nil))
-
-(defmacro stack-/-empty (stack) `(> (stack-size ,stack) 0))
-
-(defun stack-push (x stack)
-  (push x (stack-store stack))
-  (setf (stack-top stack) x (stack-updated stack) t)
-  (incf (stack-size stack))
-  x)
-
-(defun stack-pop (stack)
-  (let ((y (pop (stack-store stack))))
-    (decf (stack-size stack))
-    (setf (stack-top stack) (if (stack-/-empty stack) (car (stack-store stack))))
-    y))
-
-
 ; 1A. A Line Buffer
 ;
 ; The philosophy of lines is that
@@ -235,7 +195,7 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
 
 ; *** Print New Line
 
-(defparameter Printer-Line-Stack (make-stack)
+(defparameter Printer-Line-Stack (|makeStack|)
   "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]")
 
 (defparameter Read-Quietly nil
@@ -243,10 +203,10 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
 
 (defun Print-New-Line (string &optional (strm |$OutputStream|))
   "Makes output listings."
-  (if Read-Quietly (stack-push (copy-tree string) Printer-Line-Stack)
+  (if Read-Quietly (|stackPush!| (copy-tree string) Printer-Line-Stack)
       (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
-                   (|reverse!| (stack-store Printer-Line-Stack)))
-             (stack-clear Printer-Line-Stack)
+                   (|reverse!| (|stackStore| Printer-Line-Stack)))
+             (|stackClear!| Printer-Line-Stack)
              (format strm "~&; ~A~%" string))))
 
 
@@ -383,13 +343,13 @@ NonBlank is true if the token is not preceded by a blank."
 ;
 ;       Push-Reduction Pop-Reduction
 
-(defparameter Reduce-Stack (make-stack) "Stack of results of reduced productions.")
+(defparameter Reduce-Stack (|makeStack|) "Stack of results of reduced productions.")
 
 (defun Push-Reduction (rule redn)
-  (stack-push (make-reduction :rule rule :value redn) Reduce-Stack))
+  (|stackPush!| (make-reduction :rule rule :value redn) Reduce-Stack))
 
 (defun reduce-stack-show ()
-  (let ((store (stack-store reduce-stack))
+  (let ((store (|stackStore| reduce-stack))
         (*print-pretty* t))
     (if store
         (progn (format t "~%Reduction stack contains:~%")
@@ -397,24 +357,24 @@ NonBlank is true if the token is not preceded by a blank."
 			   (if (eq (type-of x) 'token)
                                (describe x)
 			     (print x)))
-                       (stack-store reduce-stack)))
+                       (|stackStore| reduce-stack)))
         (format t "~%There is nothing on the reduction stack.~%"))))
 
-(defmacro reduce-stack-clear () `(stack-load nil reduce-stack))
+(defmacro reduce-stack-clear () `(|stackLoad!| nil reduce-stack))
 
-(defun Pop-Reduction () (stack-pop Reduce-Stack))
+(defun Pop-Reduction () (|stackPop!| Reduce-Stack))
 
 (defmacro pop-stack-1 () '(reduction-value (Pop-Reduction)))
 
 (defmacro pop-stack-2 ()
   `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)))
-     (stack-push top Reduce-Stack)
+     (|stackPush!| top Reduce-Stack)
      (reduction-value next)))
 
 (defmacro pop-stack-3 ()
   `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)) (nnext (Pop-Reduction)))
-     (stack-push next Reduce-Stack)
-     (stack-push top Reduce-Stack)
+     (|stackPush!| next Reduce-Stack)
+     (|stackPush!| top Reduce-Stack)
      (reduction-value nnext)))
 
 (defmacro pop-stack-4 ()
@@ -422,13 +382,13 @@ NonBlank is true if the token is not preceded by a blank."
           (next (Pop-Reduction))
           (nnext (Pop-Reduction))
           (nnnext (Pop-Reduction)))
-     (stack-push nnext Reduce-Stack)
-     (stack-push next Reduce-Stack)
-     (stack-push top Reduce-Stack)
+     (|stackPush!| nnext Reduce-Stack)
+     (|stackPush!| next Reduce-Stack)
+     (|stackPush!| top Reduce-Stack)
      (reduction-value nnnext)))
 
 (defmacro nth-stack (x)
-  `(reduction-value (nth (1- ,x) (stack-store Reduce-Stack))))
+  `(reduction-value (nth (1- ,x) (|stackStore| Reduce-Stack))))
 
  
 ; *** 2. META Line Handling
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 52374f11..e2f1c2e9 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -1,6 +1,6 @@
 ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
 ;; All rights reserved.
-;; Copyright (C) 2007-2010, Gabriel Dos Reis.
+;; Copyright (C) 2007-2011, Gabriel Dos Reis.
 ;; All rights reserved.
 ;;
 ;; Redistribution and use in source and binary forms, with or without
@@ -109,11 +109,11 @@ the sub-reductions of PROD and labelling them with LAB.
 E.G., (Star IDs (parse-id)) with A B C will stack (3 IDs (A B C)),
 where (parse-id) would stack (1 ID (A)) when applied once."
 
-  `(prog ((oldstacksize (stack-size reduce-stack)))
+  `(prog ((oldstacksize (|stackSize| reduce-stack)))
          (if (not ,prod) ;(progn (format t "~&Star failed for ~A.~%" ',lab) (return nil)))
              (return nil))
     loop (if (not ,prod)
-             (let* ((newstacksize (stack-size reduce-stack))
+             (let* ((newstacksize (|stackSize| reduce-stack))
                     (number-of-new-reductions (- newstacksize oldstacksize)))
 ;              (format t "~&Starring ~A with ~D new reductions.~%"
 ;                      ',lab number-of-new-reductions)
@@ -133,11 +133,11 @@ where (parse-id) would stack (1 ID (A)) when applied once."
 "If the execution of prod does not result in an increase in the size of
 the stack, then stack a NIL. Return the value of prod."
 
-  `(progn (setf (stack-updated reduce-stack) nil)
+  `(progn (setf (|stackUpdated?| reduce-stack) nil)
 ;         (format t "~&Banging ~A~:[~; and I think the stack is updated!~].~%" ',lab
 ;                 (stack-updated reduce-stack))
           (let* ((prodvalue ,prod)
-                 (updated (stack-updated reduce-stack)))
+                 (updated (|stackUpdated?| reduce-stack)))
 ;           (format t "~&Bang thinks that ~A ~:[didn't do anything~;did something~].~&"
 ;                   ',lab prodvalue)
             (if updated
@@ -432,7 +432,7 @@ the stack, then stack a NIL. Return the value of prod."
      c1  (cond ( (not (identp tok)) (go d1)))
          (princ "/isid= ")
         ;; (princ (cond (isid "T") (t "NIL")))
-     d1  (princ "/stack= ")            (prin1 (stack-store reduce-stack))
+     d1  (princ "/stack= ")            (prin1 (|stackStore| reduce-stack))
          (setq v (apply fun* argl*))           (setq /depth (- /depth 1))
          (terpri)
          (trblanks (* 2 /depth))          (princ (stringimage (\1+ /depth)))
@@ -447,7 +447,7 @@ the stack, then stack a NIL. Return the value of prod."
      c2  (if (not (identp tok)) (go d2))
          (princ "/isid= ")
         ;; (princ (if isid "T" "NIL"))
-     d2  (princ "/stack= ")            (prin1 (stack-store reduce-stack))
+     d2  (princ "/stack= ")            (prin1 (|stackStore| reduce-stack))
          (princ "/value= ")         (prin1 v)
          (return v)))))))