diff options
| -rw-r--r-- | src/ChangeLog | 7 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 8 | ||||
| -rw-r--r-- | src/interp/lexing.boot | 88 | ||||
| -rw-r--r-- | src/interp/metalex.lisp | 76 | ||||
| -rw-r--r-- | src/interp/parsing.lisp | 14 |
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))))))) |