aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2012-05-20 21:53:30 +0000
committerdos-reis <gdr@axiomatics.org>2012-05-20 21:53:30 +0000
commitc707a9c63ad286a9492be7f2145d8b688ddf61d5 (patch)
treef8d5e214af517558b79c2e845aae2108a24fda4d /src/interp
parent47a2fd61be7c98af4d53f8b885a0038a72fcd4e6 (diff)
downloadopen-axiom-c707a9c63ad286a9492be7f2145d8b688ddf61d5.tar.gz
* interp/parsing.lisp (CONVERSATION): Remove.
(CONVERSATION1): Likewise. (MAKE-PARSE-FUNCTION): Likewise. (MAKE-PARSE-FUNCTION1): Likewise. (MAKE-PARSE-FUNC-FLATTEN): Likewise. (MAKE-PARSE-FUNC-FLATTEN-1): Likewise. (TRANSPGVAR): Likewise. (GETRULEFUNLISTS): Likewise. (REDUCTION-PRINT): Likewise. (TRACEMETA): Likewise. (TRMETA): Likewise. (TRMETA1): Likewise. (/MDEF): Likewise. * interp/macros.lisp (EXPAND-TABS): Likewise. * interp/spad.lisp (READ-SPAD): Likewise. (READ-INPUT): Likewise. (READ-SPAD0): Likewise. (READ-SPAD1): Likewise. (READ-SPAD-1): Likewise. (New,ENTRY,1): Likewise. (New,ENTRY,2): Likewise. * interp/bootlex.lisp (SPAD_SYNTAX_ERROR): Move to debug.lisp. (SPAD_LONG_ERROR): Likewise. (SPAD_SHORT_ERROR): Likewise. (SPAD_ERROR_LOC): Likewise. * interp/c-util.boot (COMP370): Move to lisp-backend.boot. (compQuietly): Move to slam.boot.
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/bootlex.lisp23
-rw-r--r--src/interp/c-util.boot14
-rw-r--r--src/interp/debug.lisp62
-rw-r--r--src/interp/lisp-backend.boot4
-rw-r--r--src/interp/macros.lisp15
-rw-r--r--src/interp/parsing.lisp256
-rw-r--r--src/interp/slam.boot11
-rw-r--r--src/interp/spad-parser.boot7
-rw-r--r--src/interp/spad.lisp57
9 files changed, 78 insertions, 371 deletions
diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp
index ec75471d..acb8d0e8 100644
--- a/src/interp/bootlex.lisp
+++ b/src/interp/bootlex.lisp
@@ -131,26 +131,3 @@
(if Y (setf (FIRST X) Y) (TRANSLABEL1 (CDR X) AL))))
((TRANSLABEL1 (FIRST X) AL) (TRANSLABEL1 (CDR X) AL))))
-; **** 5. BOOT Error Handling
-
-(defun SPAD_SYNTAX_ERROR (&rest byebye)
- "Print syntax error indication, underline character, scrub line."
- (BUMPERRORCOUNT '|syntax|)
- (COND ((AND (EQ DEBUGMODE 'YES) (NOT(CONSOLEINPUTP IN-STREAM)))
- (SPAD_LONG_ERROR))
- ((SPAD_SHORT_ERROR)))
- (IOClear)
- (throw 'spad_reader nil))
-
-(defun SPAD_LONG_ERROR ()
- (SPAD_ERROR_LOC SPADERRORSTREAM)
- (iostat)
- (unless (EQUAL OUT-STREAM SPADERRORSTREAM)
- (SPAD_ERROR_LOC OUT-STREAM)
- (TERPRI OUT-STREAM)))
-
-(defun SPAD_SHORT_ERROR () (current-line-show))
-
-(defun SPAD_ERROR_LOC (STR)
- (format str "******** Spad Syntax Error detected ********"))
-
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index b0ecbb73..a24b4539 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1759,20 +1759,6 @@ compAndDefine l ==
$compileDontDefineFunctions := true
-++ Subroutine of compileInteractive.
-compQuietly fn ==
- _*COMP370_-APPLY_* :=
- $InteractiveMode =>
- $compileDontDefineFunctions => "COMPILE-DEFUN"
- "EVAL-DEFUN"
- "PRINT-DEFUN"
- quietlyIfInteractive backendCompile fn
-
-COMP370 x ==
- first x is [.,:.] => [COMPILE1 y for y in x]
- [COMPILE1 x]
-
-
--%
--% Compile Time operation lookup for the benefit of domain inlining.
--%
diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp
index 6ece9a85..746f10c4 100644
--- a/src/interp/debug.lisp
+++ b/src/interp/debug.lisp
@@ -99,6 +99,41 @@
(defvar /fn nil)
+(DEFPARAMETER /DEPTH 0)
+
+(defparameter debugmode 'yes "Can be either YES or NO")
+
+(defun reduction-print (y rule)
+ (format t "~&")
+ (cond ((eq y t) (|sayBrightly| `(|%b| ,rule |%d| " reduced")))
+ (y (|sayBrightlyNT| `(|%b| ,rule |%d|))
+ (format t " reduced ~A~%" y)))
+ y)
+
+(defun /embed-1 (x y)
+ (princ (strconc (pname x) " embedded"))
+ (terpri)
+ (/embed-q x y))
+
+(defvar /embednames)
+
+(defun /embed-q (x y)
+ (setq /embednames (cons x /embednames))
+ (embed x
+ (cond ((eqcar y 'lambda) y)
+ ((eqcar y 'before)
+ `(lambda ,(cadr y)
+ (prog2 ,(caddr y) ,(cons 'funcall (cons x (cadr y))))))
+ ((eqcar y 'after)
+ `(lambda ,(cadr y)
+ (prog1 ,(cons 'funcall (cons x (cadr y))) ,(caddr y))))))
+ (/embedreply))
+
+(defun /embedreply ()
+ (if (atom (embedded)) '(|none| |embedded|)
+ (append (embedded) (list '|embedded|))))
+
+
(DEFUN /D-1 (L OP EFLG TFLG)
(CATCH 'FILENAM
(PROG (TO OPTIONL OPTIONS FNL INFILE OUTSTREAM FN )
@@ -130,13 +165,13 @@
ISID NBLNK COMMENTCHR $TOKSTACK (/SOURCEFILES |$sourceFiles|)
METAKEYLST DEFINITION_NAME (|$sourceFileTypes| '(|spad| |boot| |lisp| |lsp| |meta|))
($FUNCTION FN) $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK
- TRAPFLAG |$InteractiveMode| TOK ERRCOL COLUMN *QUERY CHR LINE
+ TRAPFLAG |$InteractiveMode| TOK COLUMN *QUERY CHR LINE
(*COMP370-APPLY* (if (eq op 'define) #'eval-defun #'compile-defun)))
(declare (special |$Echo| SINGLINEMODE INPUTSTREAM
SPADERRORSTREAM ISID NBLNK COMMENTCHR $TOKSTACK /SOURCEFILES
METAKEYLST DEFINITION_NAME |$sourceFileTypes|
$FUNCTION $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK
- TRAPFLAG |$InteractiveMode| TOK ERRCOL COLUMN *QUERY CHR LINE))
+ TRAPFLAG |$InteractiveMode| TOK COLUMN *QUERY CHR LINE))
(if (CONSP FN) (SETQ FN (QCAR FN)))
(SETQ INFILE (OR INFILE (|getFunctionSourceFile| FN)))
;; $FUNCTION is freely set in getFunctionSourceFile
@@ -1096,3 +1131,26 @@ EXAMINE (SETQ RECNO (NOTE |$InputStream|))
(defun interrupt (&rest ignore))
+; **** 5. BOOT Error Handling
+
+(defun SPAD_SYNTAX_ERROR (&rest byebye)
+ "Print syntax error indication, underline character, scrub line."
+ (BUMPERRORCOUNT '|syntax|)
+ (COND ((AND (EQ DEBUGMODE 'YES) (NOT(CONSOLEINPUTP IN-STREAM)))
+ (SPAD_LONG_ERROR))
+ ((SPAD_SHORT_ERROR)))
+ (IOClear)
+ (throw 'spad_reader nil))
+
+(defun SPAD_LONG_ERROR ()
+ (SPAD_ERROR_LOC SPADERRORSTREAM)
+ (iostat)
+ (unless (EQUAL OUT-STREAM SPADERRORSTREAM)
+ (SPAD_ERROR_LOC OUT-STREAM)
+ (TERPRI OUT-STREAM)))
+
+(defun SPAD_SHORT_ERROR () (current-line-show))
+
+(defun SPAD_ERROR_LOC (STR)
+ (format str "******** Spad Syntax Error detected ********"))
+
diff --git a/src/interp/lisp-backend.boot b/src/interp/lisp-backend.boot
index bb61333e..35230f86 100644
--- a/src/interp/lisp-backend.boot
+++ b/src/interp/lisp-backend.boot
@@ -806,6 +806,10 @@ COMPILE1 fun ==
compileLispDefinition(name,body)
body
+COMP370 x ==
+ first x is [.,:.] => [COMPILE1 y for y in x]
+ [COMPILE1 x]
+
assembleCode x ==
if $PrettyPrint then PRETTYPRINT x
if not $COMPILE then SAY '"No Compilation"
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 69959807..7044e6e1 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -473,21 +473,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(terpri stream)
(finish-output stream)))
-(defun expand-tabs (str)
- (if (and (stringp str) (> (length str) 0))
- (let ((bpos (|firstNonblankCharPosition| str))
- (tpos (|indentationLocation| str)))
- (setq str
- (if (eql bpos tpos)
- str
- (concatenate 'string
- (make-string tpos :initial-element #\space)
- (subseq str bpos))))
- ;; remove dos CR
- (let ((lpos (|maxIndex| str)))
- (if (eq (char str lpos) #\Return) (subseq str 0 lpos) str)))
- str))
-
;; stream handling for paste-in generation
(defun |applyWithOutputToString| (func args)
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 658286e7..828de1db 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -270,267 +270,11 @@ the stack, then stack a NIL. Return the value of prod."
; 3B. Error handling
-(defparameter errcol nil)
(defparameter line nil)
-(defun conversation (x y)
- (prog (u)
- a (|reduceStackClear|)
- (setq u (namederrset 'spad_reader (conversation1 x y) ))
- (cond (*eof* (return nil))
- ((atom u) (go a))
- ((return (car u))))))
-
-(defparameter ulcasefg nil "")
-
-(defun conversation1 (firstfun procfun)
- (prog nil
- top(cond ((not (|currentChar|)) (return nil))
- ((and (|currentToken|) (|nextToken|)) (go top))
- ((compfin) (return 't))
- ((and (funcall firstfun)
- (or (funcall procfun (|popStack1|))))
- (go top))
- ((compfin) (return 't)) )
- (spad_syntax_error)
- (go top)))
-
(defun termchr () "Is CHR a terminating character?"
(|findChar| (|currentChar|) " *,;<>()[]/\\"))
-(defun compfin () (or (|matchString| ")fin") (|matchString| ".FIN")))
-
-; 3 C. Constructing parsing procedures
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Make-Parse-Function, GetGenSym
-
-(MAKEPROP 'PROGN 'NARY T) ; Setting for Make-Parse-Function
-
-(defun make-parse-function (l op)
- (if (flagp op 'nary) (setq l (make-parse-func-flatten-1 l op nil)))
- (make-parse-function1 l op))
-
-(defun make-parse-func-flatten (x op)
- (cond ((atom x) x)
- ((eq (car x) op) (cons op (make-parse-func-flatten-1 (cdr x) op nil)))
- (t (cons (make-parse-func-flatten (car x) op) (make-parse-func-flatten (cdr x) op)))))
-
-(defun make-parse-func-flatten-1 (l op r)
- (let (x)
- (if (null l)
- r
- (make-parse-func-flatten-1
- (cdr l) op
- (append r (if (eqcar (setq x (make-parse-func-flatten (car l) op)) op)
- (cdr x)
- (list x)))))))
-
-(defun make-parse-function1 (l op)
- (let (x)
- (case op
- (plus (cond ((eq 0 (setq x (length (setq l (s- l '(0 (zero))))))) 0)
- ((eq 1 x) (car l))
- (t `(+ . ,l))))
- (times (cond ((s* l '(0 (zero))) 0)
- ((eq 0 (setq x (length (setq l (s- l '(1 (one))))))) 1)
- ((eq 1 x) (car l))
- (t `(times . ,l)) ))
- (quotient (cond ((> (length l) 2) (fail))
- ((eq 0 (car l)) 0)
- ((eq (cadr l) 1) (car l))
- (t `(quotient . ,l)) ))
- (minus (cond ((cdr l) (fail))
- ((numberp (setq x (car l))) (minus x))
- ((eqcar x 'minus) (cadr x))
- (t `(minus . ,l)) ))
- (- (cond ((> (length l) 2) (fail))
- ((equal (car l) (cadr l)) '(zero))
- ((member (car l) '(0 (zero))) (make-parse-function (cdr l) 'minus))
- ((member (cadr l) '(0 (zero))) (car l))
- ((eqcar (cadr l) 'minus)
- (make-parse-function (list (car l) (cadadr l)) 'plus))
- (t `(- . ,l)) ))
- (expt (cond ((> (length l) 2) (fail))
- ((eq 0 (cadr l)) 1)
- ((eq 1 (cadr l)) (car l))
- ((member (car l) '(0 1 (zero) (one))) (car l))
- (t `(expt . ,l)) ))
- (or (cond ((member 't l) ''t)
- ((eq 0 (setq x (length (setq l (delete nil l))))) nil)
- ((eq 1 x) (car l))
- (t `(or . ,l)) ))
- (|or| (cond ((member 't l) 't)
- ((eq 0 (setq x (length (setq l (delete nil l))))) nil)
- ((eq 1 x) (car l))
- (t `(|or| . ,l)) ))
- (null (cond ((cdr l) (fail))
- ((eqcar (car l) 'null) (cadar l))
- ((eq (car l) 't) nil)
- ((null (car l)) ''t)
- (t `(null . ,l))))
- (|and| (cond ((eq 0 (setq x (length (setq l (delete 't (delete 'true l)))))) 't)
- ((eq 1 x) (car l))
- (t `(|and| . ,l)) ))
- (and (cond ((eq 0 (setq x (length (setq l (delete 't (delete 'true l)))))) ''t)
- ((eq 1 x) (car l))
- (t `(and . ,l)) ))
- (progn (cond ((and (not (atom l)) (null (last l)))
- (cond ((cdr l) `(progn . ,l))
- (t (car l))))
- ((null (setq l (delete nil l))) nil)
- ((cdr l) `(progn . ,l))
- (t (car l)) ))
- (seq (cond ((eqcar (car l) 'exit) (cadar l))
- ((cdr l) `(seq . ,l))
- (t (car l)) ))
- (list (cond ((null l) nil) (t `(list . ,l))))
- (cons (cond ((cdr l) `(cons . ,l)) (t (car l)) ))
- (t (cons op l) ))))
-
-(defparameter /genvarlst nil "??")
-
-(defun transpgvar (metapgvar) (remove-duplicates metapgvar))
-
-(defparameter /gensymlist nil "List of rule local variables generated by getgensym.")
-
-(defun getgensym (n)
- "Used to create unique numerically indexed local variables for the use of rules."
- (loop
- (let ((m (length /gensymlist)))
- (if (< m n)
- (setq /gensymlist (|append!| /gensymlist `(,(intern (format nil "G~D" (1+ m))))))
- (return (nth (1- n) /gensymlist))))))
-
-; 3 D. Managing rule sets
-
-(defparameter bac nil "")
-(defparameter keyfn nil "")
-(defparameter /metaoption "")
-(defparameter tline nil "")
-(defparameter rs nil "")
-
-(defun getrulefunlists (rootfun rs)
- (let* ((metapfx (or (get rootfun 'metapfx) ""))
- (mainfun (internl metapfx (pname rootfun)))
- (mainfunstr (pname mainfun))
- (flnam (internl mainfunstr "FUN"))
- (pfx-funlist (union (cons mainfun
- (if (atom (eval flnam)) nil (eval flnam)))
- (mapcar #'(lambda (x) (internl metapfx (pname x)))
- (assocleft rs))))
- n unpfx-funlist)
- (setf (symbol-value flnam) pfx-funlist)
- (if (not (lessp (setq n (length metapfx)) 0))
- (setq unpfx-funlist
- (mapcar #'(lambda (x)
- (intern (subseq
- (symbol-name (copy-symbol (pname x))) n)))
- pfx-funlist)))
- (if unpfx-funlist (list pfx-funlist unpfx-funlist))))
-
-; 4. Tracing routines
-
-(defparameter debugmode 'yes "Can be either YES or NO")
-
-(defun reduction-print (y rule)
- (format t "~&")
- (cond ((eq y t) (|sayBrightly| `(|%b| ,rule |%d| " reduced")))
- (y (|sayBrightlyNT| `(|%b| ,rule |%d|))
- (format t " reduced ~A~%" y)))
- y)
-
-(defmacro tracemeta (&rest l) `(trmeta ',l))
-
-(defparameter /depth 0 "Used in Debug.lisp.")
-
-(defun trmeta (l) (setq /depth 0) (mapc #'trmeta1 l))
-
-(defun trmeta1 (x)
- (let (y)
- (if (not (fboundp x))
- (if (fboundp (setq y (internl $lastprefix (pname x))))
- (moan (format nil "********* ~S RENAMED AS ~S" x (setq x y)))
- (croak (format nil "********* ~S MUST BE GIVEN PREFIX" x))))
- (/embed-1 x
- (sublislis
- (list (pname x) x (gensym))
- '(nam* fun* argl*)
- '(lambda (&rest argl*)
- (prog (v tok)
- (terpri)
- (trblanks (* 2 /depth)) (setq /depth (+ 1 /depth))
- (princ (stringimage /depth)) (princ "<")
- (princ nam*) (trargprint argl*) (princ "/")
- (princ "chr= ") (prin1 (|currentChar|))
- (princ "/tok= ") (prin1 (setq tok (current-symbol)))
- (princ "/col= ") (prin1 (|lineCurrentIndex| |$spadLine|))
- ;; (princ "/icol= ") (prin1 initcolumn)
- (cond ( (not nonblank) (go a1))) (princ "/nblnk= T")
- a1 ;;(cond (ok (go b1))) (princ "/ok= NIL")
- b1 ;;(cond ( (not stackx) (go c1))) (princ "/stackx= ")
- ;;(prin1 stackx)
- c1 (cond ( (not (|ident?| tok)) (go d1)))
- (princ "/isid= ")
- ;; (princ (cond (isid "T") (t "NIL")))
- d1 (princ "/stack= ") (prin1 (|stackStore| |$reduceStack|))
- (setq v (apply fun* argl*)) (setq /depth (- /depth 1))
- (terpri)
- (trblanks (* 2 /depth)) (princ (stringimage (\1+ /depth)))
- (princ ">") (princ nam*)
- (princ "/chr= ") (prin1 (|currentChar|))
- (princ "/tok= ") (prin1 (setq tok (current-symbol)))
- (princ "/col= ") (prin1 (|lineCurrentIndex| |$spadLine|))
- (if (not nonblank) (go a2)) (princ "/nblnk= ")
- (princ (if nonblank "T" "NIL"))
- a2 ;;(if ok (go b2)) (princ "/ok= ") (prin1 ok)
- b2 ;;(if (not stackx) (go c2)) (princ "/stackx1= ") (prin1 stackx)
- c2 (if (not (|ident?| tok)) (go d2))
- (princ "/isid= ")
- ;; (princ (if isid "T" "NIL"))
- d2 (princ "/stack= ") (prin1 (|stackStore| |$reduceStack|))
- (princ "/value= ") (prin1 v)
- (return v)))))))
-
-(defun /embed-1 (x y)
- (princ (strconc (pname x) " embedded"))
- (terpri)
- (/embed-q x y))
-
-(defvar /embednames)
-
-(defun /embed-q (x y)
- (setq /embednames (cons x /embednames))
- (embed x
- (cond ((eqcar y 'lambda) y)
- ((eqcar y 'before)
- `(lambda ,(cadr y)
- (prog2 ,(caddr y) ,(cons 'funcall (cons x (cadr y))))))
- ((eqcar y 'after)
- `(lambda ,(cadr y)
- (prog1 ,(cons 'funcall (cons x (cadr y))) ,(caddr y))))))
- (/embedreply))
-
-(defun /embedreply ()
- (if (atom (embedded)) '(|none| |embedded|)
- (append (embedded) (list '|embedded|))))
-
-(defparameter mdeftrace nil "")
-
-(defun /mdef (x)
- (let (u)
- (cond ((atom x) x)
- ((or (null (atom (car x))) (not (mbpip (car x))))
- (mapcar #'/mdef x))
- ((equal x (setq u (mdef (car x) x))) x)
- (mdeftrace (print x) (princ " --> ") (print u) (/mdef u))
- ((/mdef u)))))
-
-(defun trargprint (l) (mapc #'(lambda (x) (princ " / ") (prin1 x)) l))
-
-(defun trblanks (n) (do ((i 1 (1+ i))) ((> i n)) (princ " ")))
-
; 5. Routines for inspecting and resetting total I/O system state
;
; The package largely assumes that:
diff --git a/src/interp/slam.boot b/src/interp/slam.boot
index c48b0cbf..5a74a0cb 100644
--- a/src/interp/slam.boot
+++ b/src/interp/slam.boot
@@ -406,7 +406,16 @@ compileInteractive fn ==
result := compQuietly optfn
if $InteractiveMode then stopTimingProcess 'compilation
result
-
+
+++ Subroutine of compileInteractive.
+compQuietly fn ==
+ _*COMP370_-APPLY_* :=
+ $InteractiveMode =>
+ $compileDontDefineFunctions => "COMPILE-DEFUN"
+ "EVAL-DEFUN"
+ "PRINT-DEFUN"
+ quietlyIfInteractive backendCompile fn
+
clearAllSlams x ==
fn(x,nil) where
fn(thoseToClear,thoseCleared) ==
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index 54c6fa82..6bcfca02 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -161,8 +161,8 @@ preparseEcho lines ==
formatToStream(OUT_-STREAM,'"~&;~A~%",x)
$EchoLineStack := nil
-++ The line to be worked on is (CAR SLINES).
-++ It's indentation is (CAR SLOCS).
+++ The line to be worked on is the first in `lines.
+++ It's indentation is the first in `locs'.
++ There is a notion of current indentation. Then:
++
++ A. Add open paren to beginning of following line if following
@@ -171,7 +171,8 @@ preparseEcho lines ==
++ B. Add semicolon to end of line if following line's indentation is
++ the same.
++ C. If the entire line consists of the single keyword then or else,
-++ leave it alone.
+++ leave it alone.
+addParensAndSemisToLine: (%List %String,%List %Maybe %Short) -> %Void
addParensAndSemisToLine(lines,locs) ==
sc := first locs -- first line column number
sc = nil or sc <= 0 => nil
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index aa1971a1..78d6cc66 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -140,23 +140,6 @@
(if *spad-output-file* (shut out-stream)))
T))
-(defun READ-SPAD1 (FN FT FM TO)
- (LET ((STRM IN-STREAM))
- (SETQ $MAXLINENUMBER 0)
- (SETQ $SPAD_ERRORS (VECTOR 0 0 0))
- (SETQ IN-STREAM (open (strconc fm ">" fn "." ft) :direction :input))
- ($ERASE (LIST FN 'ERROR 'A))
- (SETQ OUT-STREAM (if TO (open to :direction :output) OUT-STREAM))
- (SETQ SPADERRORSTREAM (open (strconc "a>" fn ".error") :direction :output))
- (READ-SPAD-1)
- (close SPADERRORSTREAM)
- (SETQ IN-STREAM STRM)
- (OR (EQUAL #(0 0 0) $SPAD_ERRORS)
- (|sayBrightly| (LIST '|%b| (ELT $SPAD_ERRORS 0) '|%d| '|syntax errors|
- '|%l| '|%b| (ELT $SPAD_ERRORS 1) '|%d| '|precompilation errors|
- '|%l| '|%b| (ELT $SPAD_ERRORS 2) '|%d| '|semantic errors| '|%l|)))
- (+ (ELT $SPAD_ERRORS 0) (ELT $SPAD_ERRORS 1) (ELT $SPAD_ERRORS 2))))
-
(DEFUN INTEGER-BIT (N I) (LOGBITP I N))
(DEFUN /TRANSPAD (X)
@@ -188,23 +171,6 @@
(|comp| |$x| |$m| |$f|)
(UNEMBED '|comp|))
-(defun READ-SPAD (FN FM TO)
- (LET ((proplist
- (LIST '(FLUID . |true|)
- (CONS '|special| (COPY-TREE |$InitialDomainsInScope|)))))
- (SETQ |$InteractiveFrame|
- (|addBinding| '|$DomainsInScope| proplist
- (|addBinding| '|$Information| NIL
- (|makeInitialModemapFrame|))))
- (READ-SPAD0 FN 'SPAD FM TO)))
-
-(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO))
-
-(defun READ-SPAD0 (FN FT FM TO)
- (let (($newspad t)) (READ-SPAD1 FN FT FM TO)))
-
-(defun READ-SPAD-1 () (|New,ENTRY,1|))
-
(defun UNCONS (X)
(COND ((ATOM X) X)
((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X))))
@@ -338,29 +304,6 @@
(if |$InteractiveMode| (|spadThrow|))
(S-PROCESS x))))
-(defun |New,ENTRY,1| ()
- (let (ZZ str N RLGENSYMFG RLGENSYMLST
- SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT)
- $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM
- STACK STACKX TRAPFLAG)
- (PROMPT)
- (SETQ COMMENTCHR 'IGNORE)
- (SETQ INITCOLUMN 0)
- (SETQ SINGLELINEMODE T) ; SEE NewSYSTOK
- (SETQ ULCASEFG T)
- (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| |$InputStream|))
- (if (/= 0 (setq N (NOTE STR)))
- (progn (SETQ |$InputStream| (POINTW N |$InputStream|)))
- )
- '|END_OF_New|))
-
-(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM))
- (let (zz)
- (INITIALIZE)
- (SETQ |$previousTime| (TEMPUS-FUGIT))
- (setq ZZ (CONVERSATION '|parseNewExpr| '|process|))
- INPUTSTREAM))
-
(defun INITIALIZE ()
(init-boot/spad-reader)
(initialize-preparse |$InputStream|))