aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in8
-rw-r--r--src/interp/lexing.boot88
-rw-r--r--src/interp/metalex.lisp76
-rw-r--r--src/interp/parsing.lisp14
4 files changed, 118 insertions, 68 deletions
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)))))))
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-25 00:22:01 +0000