;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
;; Copyright (C) 2007-2012, 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 The Numerical Algorithms Group Ltd. 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.
;; NAME: Pre-Parsing Code
;; PURPOSE: BOOT lines are massaged by preparse to make them easier to parse:
;; 1. Trailing -- comments are removed (this is already done, actually).
;; 2. Comments between { and } are removed.
;; 3. BOOT code is column-sensitive. Code which lines up columnarly is
;; parenthesized and semicolonized accordingly. For example,
;;
;; a
;; b
;; c
;; d
;; e
;;
;; becomes
;;
;; a
;; (b;
;; c
;; d)
;; e
;;
;; Note that to do this correctly, we also need to keep track of
;; parentheses already in the code.
(IMPORT-MODULE "lexing")
(in-package "BOOT")
; Global storage
(defparameter $INDEX 0 "File line number of most recently read line.")
(defparameter |$preparseLastLine| () "Most recently read line.")
(defparameter |$preparseReportIfTrue| NIL "Should we print listings?")
(defparameter |$LineList| nil "Stack of preparsed lines.")
(defparameter |$EchoLineStack| nil "Stack of lines to list.")
(defparameter $IOIndex 0 "Number of latest terminal input line.")
(DEFPARAMETER TOK NIL)
(DEFPARAMETER DEFINITION_NAME NIL)
(defun Initialize-Preparse (strm)
(setq $INDEX 0 |$LineList| nil |$EchoLineStack| nil)
(setq |$preparseLastLine| (|readLine| strm)))
(defvar $skipme)
(defun |preparse1| (LineList)
(PROG ((|$LineList| LineList) |$EchoLineStack| NUM A I L PSLOC
INSTRING PCOUNT COMSYM STRSYM OPARSYM CPARSYM N NCOMSYM
(SLOC -1) (CONTINUE NIL) (PARENLEV 0) (NCOMBLOCK ())
(LINES ()) (LOCS ()) (NUMS ()) functor )
READLOOP (DCQ (NUM . A) (|preparseReadLine| LineList))
(cond ((|atEndOfUnit?| A)
(|preparseEcho| LineList)
(COND ((NULL LINES) (RETURN NIL))
(NCOMBLOCK
(|findCommentBlock| NIL NUMS LOCS NCOMBLOCK NIL)))
(RETURN (|pairList| (|reverse!| NUMS)
(|parsePiles| (|reverse!| LOCS) (|reverse!| LINES))))))
(cond ((and (NULL LINES) (> (LENGTH A) 0) (EQ (CHAR A 0) #\) ))
; this is a command line, don't parse it
(|preparseEcho| LineList)
(setq |$preparseLastLine| nil) ;don't reread this line
(SETQ LINE a)
(CATCH 'SPAD_READER (|doSystemCommand| (subseq LINE 1)))
(GO READLOOP)))
(setq L (LENGTH A))
(if (EQ L 0)
(GO READLOOP))
(setq PSLOC SLOC)
(setq I 0
INSTRING ()
PCOUNT 0)
STRLOOP (setq STRSYM (OR (|findChar| #\" A I) L))
(setq COMSYM (OR (|findString| "--" A I) L))
(setq NCOMSYM (OR (|findString| "++" A I) L))
(setq OPARSYM (OR (|findChar| #\( A I) L))
(setq CPARSYM (OR (|findChar| #\) A I) L))
(setq N (MIN STRSYM COMSYM NCOMSYM OPARSYM CPARSYM))
(cond ((= N L)
(GO NOCOMS))
((|escaped?| A N))
((= N STRSYM) (setq INSTRING (NOT INSTRING)))
(INSTRING)
((= N COMSYM)
(setq A (subseq A 0 N))
(GO NOCOMS)) ; discard trailing comment
((= N NCOMSYM)
(setq SLOC (|indentationLocation| A))
(COND
((= SLOC N)
(COND ((AND NCOMBLOCK (NOT (= N (CAR NCOMBLOCK))))
(|findCommentBlock| NUM NUMS LOCS NCOMBLOCK linelist)
(SETQ NCOMBLOCK NIL)))
(SETQ NCOMBLOCK (CONS N (CONS A (IFCDR NCOMBLOCK))))
(SETQ A ""))
('T (PUSH (STRCONC (|makeString| N #\Space)
(SUBSTRING A N ())) |$LineList|)
(SETQ $INDEX (1- $INDEX))
(SETQ A (SUBSEQ A 0 N))))
(GO NOCOMS))
((= N OPARSYM) (setq PCOUNT (1+ PCOUNT)))
((= N CPARSYM) (setq PCOUNT (1- PCOUNT))))
(setq I (1+ N))
(GO STRLOOP)
NOCOMS (setq SLOC (|indentationLocation| A))
(setq A (|trimTrailingBlank| A))
(cond ((NULL SLOC)
(setq SLOC PSLOC)
(GO READLOOP)))
(cond ((EQ (ELT A (|maxIndex| A)) #\_)
(setq CONTINUE T a (subseq A (|maxIndex| A))))
((setq CONTINUE NIL)))
(if (and (null LINES) (= SLOC 0)) ;;test for skipping constructors
(if (and |$byConstructors|
(null (|findString| "==>" a))
(not (member (setq functor (intern
(substring a 0 (STRPOSL ": (=" A 0 NIL))))
|$byConstructors|)))
(setq $skipme 't)
(progn (push functor |$constructorsSeen|)
(setq $skipme nil))))
(when (and LINES (EQL SLOC 0))
(IF (AND NCOMBLOCK (NOT (ZEROP (CAR NCOMBLOCK))))
(|findCommentBlock| NUM NUMS LOCS NCOMBLOCK linelist))
(IF (NOT (|ioTerminal?| in-stream))
(setq |$preparseLastLine|
(|reverse!| |$EchoLineStack|)))
(RETURN (|pairList| (|reverse!| NUMS)
(|parsePiles| (|reverse!| LOCS) (|reverse!| LINES)))))
(cond ((> PARENLEV 0)
(PUSH NIL LOCS)
(setq SLOC PSLOC)
(GO REREAD)))
(COND (NCOMBLOCK
(|findCommentBlock| NUM NUMS LOCS NCOMBLOCK linelist)
(setq NCOMBLOCK ())))
(PUSH SLOC LOCS)
REREAD (|preparseEcho| LineList)
(PUSH A LINES)
(PUSH NUM NUMS)
(setq PARENLEV (+ PARENLEV PCOUNT))
(when (and (|ioTerminal?| in-stream) (not continue))
(setq |$preparseLastLine| nil)
(RETURN (|pairList| (|reverse!| NUMS)
(|parsePiles| (|reverse!| LOCS) (|reverse!| LINES)))))
(GO READLOOP)))