diff --git a/changelog b/changelog index e840c7b..b952c51 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090823 tpd src/axiom-website/patches.html 20090823.05.tpd.patch +20090823 tpd src/interp/Makefile move int-top.boot to int-top.lisp +20090823 tpd src/interp/int-top.lisp added, rewritten from int-top.boot +20090823 tpd src/interp/int-top.boot removed, rewritten to int-top.lisp 20090823 tpd src/axiom-website/patches.html 20090823.04.tpd.patch 20090823 tpd src/interp/Makefile move incl.boot to incl.lisp 20090823 tpd src/interp/incl.lisp added, rewritten from incl.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 32fbc3a..eb3be88 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1852,7 +1852,9 @@ src/interp/Makefile stop building DOCFILES
i-toplev.lisp rewrite from boot to lisp
20090823.03.tpd.patch i-util.lisp rewrite from boot to lisp
-20090823.03.tpd.patch +20090823.04.tpd.patch incl.lisp rewrite from boot to lisp
+20090823.05.tpd.patch +int-top.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 8857a7b..cb63696 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -5409,45 +5409,26 @@ ${DOC}/sfsfun-l.lisp.dvi: ${IN}/sfsfun-l.lisp.pamphlet @ -\subsection{int-top.boot} +\subsection{int-top.lisp} <>= -${OUT}/int-top.${O}: ${MID}/int-top.clisp - @ echo 564 making ${OUT}/int-top.${O} from ${MID}/int-top.clisp - @ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/int-top.clisp"' \ +${OUT}/int-top.${O}: ${MID}/int-top.lisp + @ echo 136 making ${OUT}/int-top.${O} from ${MID}/int-top.lisp + @ ( cd ${MID} ; \ + if [ -z "${NOISE}" ] ; then \ + echo '(progn (compile-file "${MID}/int-top.lisp"' \ ':output-file "${OUT}/int-top.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/int-top.clisp"' \ + echo '(progn (compile-file "${MID}/int-top.lisp"' \ ':output-file "${OUT}/int-top.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ - fi + fi ) @ -<>= -${MID}/int-top.clisp: ${IN}/int-top.boot.pamphlet - @ echo 565 making ${MID}/int-top.clisp from ${IN}/int-top.boot.pamphlet +<>= +${MID}/int-top.lisp: ${IN}/int-top.lisp.pamphlet + @ echo 137 making ${MID}/int-top.lisp from ${IN}/int-top.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/int-top.boot.pamphlet >int-top.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "${MID}/int-top.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "${MID}/int-top.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ; \ - rm int-top.boot ) - -@ -<>= -${DOC}/int-top.boot.dvi: ${IN}/int-top.boot.pamphlet - @echo 566 making ${DOC}/int-top.boot.dvi \ - from ${IN}/int-top.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/int-top.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} int-top.boot ; \ - rm -f ${DOC}/int-top.boot.pamphlet ; \ - rm -f ${DOC}/int-top.boot.tex ; \ - rm -f ${DOC}/int-top.boot ) + ${TANGLE} ${IN}/int-top.lisp.pamphlet >int-top.lisp ) @ @@ -6292,8 +6273,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/int-top.boot.pamphlet b/src/interp/int-top.boot.pamphlet deleted file mode 100644 index 482b395..0000000 --- a/src/interp/int-top.boot.pamphlet +++ /dev/null @@ -1,248 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp int-top.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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. - -@ -<<*>>= -<> - -)package "BOOT" - ---% INTERPRETER TOP LEVEL - -intloopProcess(n,interactive,s)== - StreamNull s => n - [lines,ptree]:=CAR s - pfAbSynOp?(ptree,"command")=> - if interactive then setCurrentLine tokPart ptree - FUNCALL($systemCommandFunction, tokPart ptree) - intloopProcess(n ,interactive ,CDR s) - intloopProcess(intloopSpadProcess(n,lines,ptree,interactive) - ,interactive ,CDR s) - -intloopEchoParse s== - [dq,stream]:=CAR s - [lines,rest]:=ncloopDQlines(dq,$lines) - setCurrentLine(mkLineList(lines)) - if $EchoLines then ncloopPrintLines lines - $lines:=rest - cons([[lines,npParse dqToList dq]],CDR s) - -intloopInclude1(name,n) == - a:=ncloopIncFileName name - a => intloopInclude(a,n) - n - -intloopProcessString(s,n) == - setCurrentLine s - intloopProcess(n,true, - next(function ncloopParse, - next(function lineoftoks,incString s))) - -$pfMacros := [] - -intloopSpadProcess(stepNo,lines,ptree,interactive?)== - $stepNo:local := stepNo - $currentCarrier := cc := ['carrier] - ncPutQ(cc, 'stepNumber, stepNo) - ncPutQ(cc, 'messages, $ncMsgList) - ncPutQ(cc, 'lines, lines) - $ncMsgList := nil - result := CatchAsCan(flung, Catch("SpadCompileItem", - CATCH($intCoerceFailure, CATCH($intSpadReader, - interp(cc, ptree, interactive?))))) where - - interp(cc, ptree, interactive?) == - ncConversationPhase(function phParse, [cc, ptree]) - ncConversationPhase(function phMacro, [cc]) - ncConversationPhase(function phIntReportMsgs,[cc, interactive?]) - ncConversationPhase(function phInterpret, [cc]) - - #ncEltQ(cc, 'messages) ^= 0 => ncError() - - intSetNeedToSignalSessionManager() - $prevCarrier := $currentCarrier - result = 'ncEnd => stepNo - result = 'ncError => stepNo - result = 'ncEndItem => stepNo - stepNo+1 - -phInterpret carrier == - ptree := ncEltQ(carrier, 'ptree) - val := intInterpretPform(ptree) - ncPutQ(carrier, 'value, val) - - ---% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] -phIntReportMsgs(carrier, interactive?) == - $erMsgToss => 'OK - lines := ncEltQ(carrier, 'lines) - msgs := ncEltQ(carrier, 'messages) - nerr := #msgs - ncPutQ(carrier, 'ok?, nerr = 0) - nerr = 0 => 'OK - processMsgList(msgs, lines) - intSayKeyedMsg ('S2CTP010,[nerr]) - 'OK - -mkLineList lines == - l := [CDR line for line in lines | nonBlank CDR line] - #l = 1 => CAR l - l - -nonBlank str == - value := false - for i in 0..MAXINDEX str repeat - str.i ^= char " " => - value := true - return value - value - -ncloopDQlines (dq,stream)== - StreamNull stream - a:= poGlobalLinePosn tokPosn CADR dq - b:= poGlobalLinePosn CAAR stream - streamChop (a-b+1,stream) - -streamChop(n,s)== - if StreamNull s - then [nil,nil] - else if EQL(n,0) - then [nil,s] - else - [a,b]:= streamChop(n-1,cdr s) - line:=car s - c:=ncloopPrefix?('")command",CDR line) - d:= cons(car line,if c then c else cdr line) - [cons(d,a),b] - -ncloopPrintLines lines == - for line in lines repeat WRITE_-LINE CDR line - WRITE_-LINE '" " - -ncloopParse s== - [dq,stream]:=CAR s - [lines,rest]:=ncloopDQlines(dq,stream) - cons([[lines,npParse dqToList dq]],CDR s) - -ncloopInclude0(st, name, n) == - $lines:local := incStream(st, name) - ncloopProcess(n,false, - next(function ncloopEchoParse, - next(function insertpile, - next(function lineoftoks,$lines)))) - -incString s== incRenumber incLude(0,[s],0,['"strings"] ,[Top]) - -ncError() == - THROW("SpadCompileItem",'ncError) - ---% Compilation Carriers --- This data structure is used to carry information between phases. - ---% phParse: carrier[tokens,...] -> carrier[ptree, tokens,...] ---)line (defun pretty (x) (boottran::reallyprettyprint x)) ---)line (defun packagetran (x) (boot::|packageTran|)) -phParse(carrier,ptree) == - phBegin 'Parsing - if $ncmParse then - nothing - intSayKeyedMsg ('S2CTP003,[%pform ptree]) - ncPutQ(carrier, 'ptree, ptree) - 'OK - - ---% phMacro: carrier[ptree,...] -> carrier[ptree, ptreePremacro,...] -phMacro carrier == - phBegin 'Macroing - ptree := ncEltQ(carrier, 'ptree) - ncPutQ(carrier, 'ptreePremacro, ptree) - - ptree := macroExpanded ptree - if $ncmMacro then - intSayKeyedMsg ('S2CTP007,[%pform ptree] ) - - ncPutQ(carrier, 'ptree, ptree) - 'OK - ---% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] -phReportMsgs(carrier, interactive?) == - $erMsgToss => 'OK - lines := ncEltQ(carrier, 'lines) - msgs := ncEltQ(carrier, 'messages) - nerr := #msgs - ncPutQ(carrier, 'ok?, nerr = 0) - interactive? and nerr = 0 => 'OK - processMsgList(msgs, lines) - intSayKeyedMsg ('S2CTP010,[nerr]) - 'OK - -ncConversationPhase(fn, args) == - carrier := first args - - $ncMsgList: local := [] - $convPhase: local := 'NoPhase - - UNWIND_-PROTECT( APPLY(fn, args), wrapup(carrier) ) where - wrapup(carrier) == - for m in $ncMsgList repeat - ncPutQ(carrier, 'messages, [m, :ncEltQ(carrier, 'messages)]) - -phBegin id == - $convPhase := id - if $ncmPhase then intSayKeyedMsg('S2CTP021,[id]) - -PullAndExecuteSpadSystemCommand stream == - ExecuteSpadSystemCommand CAR stream - CDR stream - -ExecuteSpadSystemCommand string == - FUNCALL($systemCommandFunction, string) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} [[src/interp/server.boot.pamphlet]] -\bibitem{2} [[src/interp/vmlisp.lisp.pamphlet]] -\end{thebibliography} -\end{document} diff --git a/src/interp/int-top.lisp.pamphlet b/src/interp/int-top.lisp.pamphlet new file mode 100644 index 0000000..9e50db0 --- /dev/null +++ b/src/interp/int-top.lisp.pamphlet @@ -0,0 +1,539 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp int-top.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT") + +;--% INTERPRETER TOP LEVEL + +;intloopProcess(n,interactive,s)== +; StreamNull s => n +; [lines,ptree]:=CAR s +; pfAbSynOp?(ptree,"command")=> +; if interactive then setCurrentLine tokPart ptree +; FUNCALL($systemCommandFunction, tokPart ptree) +; intloopProcess(n ,interactive ,CDR s) +; intloopProcess(intloopSpadProcess(n,lines,ptree,interactive) +; ,interactive ,CDR s) + +(DEFUN |intloopProcess| (|n| |interactive| |s|) + (PROG (|ptree| |lines| |LETTMP#1|) + (DECLARE (SPECIAL |$systemCommandFunction|)) + (RETURN + (COND + ((|StreamNull| |s|) |n|) + ('T + (PROGN + (SETQ |LETTMP#1| (CAR |s|)) + (SETQ |lines| (CAR |LETTMP#1|)) + (SETQ |ptree| (CADR |LETTMP#1|)) + (COND + ((|pfAbSynOp?| |ptree| '|command|) + (PROGN + (COND + (|interactive| + (|setCurrentLine| (|tokPart| |ptree|)))) + (FUNCALL |$systemCommandFunction| (|tokPart| |ptree|)) + (|intloopProcess| |n| |interactive| (CDR |s|)))) + ('T + (|intloopProcess| + (|intloopSpadProcess| |n| |lines| |ptree| + |interactive|) + |interactive| (CDR |s|)))))))))) + +;intloopEchoParse s== +; [dq,stream]:=CAR s +; [lines,rest]:=ncloopDQlines(dq,$lines) +; setCurrentLine(mkLineList(lines)) +; if $EchoLines then ncloopPrintLines lines +; $lines:=rest +; cons([[lines,npParse dqToList dq]],CDR s) +(DEFUN |intloopEchoParse| (|s|) + (PROG (CDR |lines| |stream| |dq| |LETTMP#1|) + (DECLARE (SPECIAL |$EchoLines| |$lines|)) + (RETURN + (PROGN + (SETQ |LETTMP#1| (CAR |s|)) + (SETQ |dq| (CAR |LETTMP#1|)) + (SETQ |stream| (CADR |LETTMP#1|)) + (SETQ |LETTMP#1| (|ncloopDQlines| |dq| |$lines|)) + (SETQ |lines| (CAR |LETTMP#1|)) + (SETQ CDR (CADR |LETTMP#1|)) + (|setCurrentLine| (|mkLineList| |lines|)) + (COND (|$EchoLines| (|ncloopPrintLines| |lines|))) + (SETQ |$lines| CDR) + (CONS (LIST (LIST |lines| (|npParse| (|dqToList| |dq|)))) + (CDR |s|)))))) + +;intloopInclude1(name,n) == +; a:=ncloopIncFileName name +; a => intloopInclude(a,n) +; n + +(DEFUN |intloopInclude1| (|name| |n|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|ncloopIncFileName| |name|)) + (COND (|a| (|intloopInclude| |a| |n|)) ('T |n|)))))) + +;intloopProcessString(s,n) == +; setCurrentLine s +; intloopProcess(n,true, +; next(function ncloopParse, +; next(function lineoftoks,incString s))) + +(DEFUN |intloopProcessString| (|s| |n|) + (PROG () + (RETURN + (PROGN + (|setCurrentLine| |s|) + (|intloopProcess| |n| T + (|next| #'|ncloopParse| + (|next| #'|lineoftoks| (|incString| |s|)))))))) + +;$pfMacros := [] + +(EVAL-WHEN (EVAL LOAD) (SETQ |$pfMacros| NIL)) + +;intloopSpadProcess(stepNo,lines,ptree,interactive?)== +; $stepNo:local := stepNo +; $currentCarrier := cc := ['carrier] +; ncPutQ(cc, 'stepNumber, stepNo) +; ncPutQ(cc, 'messages, $ncMsgList) +; ncPutQ(cc, 'lines, lines) +; $ncMsgList := nil +; result := CatchAsCan(flung, Catch("SpadCompileItem", +; CATCH($intCoerceFailure, CATCH($intSpadReader, +; interp(cc, ptree, interactive?))))) where +; +; interp(cc, ptree, interactive?) == +; ncConversationPhase(function phParse, [cc, ptree]) +; ncConversationPhase(function phMacro, [cc]) +; ncConversationPhase(function phIntReportMsgs,[cc, interactive?]) +; ncConversationPhase(function phInterpret, [cc]) +; +; #ncEltQ(cc, 'messages) ^= 0 => ncError() +; +; intSetNeedToSignalSessionManager() +; $prevCarrier := $currentCarrier +; result = 'ncEnd => stepNo +; result = 'ncError => stepNo +; result = 'ncEndItem => stepNo +; stepNo+1 + +(DEFUN |intloopSpadProcess| (|stepNo| |lines| |ptree| |interactive?|) + (PROG (|$stepNo| |result| |cc|) + (DECLARE (SPECIAL |$stepNo| |$prevCarrier| |$intSpadReader| + |$intCoerceFailure| |$ncMsgList| + |$currentCarrier|)) + (RETURN + (PROGN + (SETQ |$stepNo| |stepNo|) + (SETQ |$currentCarrier| (SETQ |cc| (LIST '|carrier|))) + (|ncPutQ| |cc| '|stepNumber| |stepNo|) + (|ncPutQ| |cc| '|messages| |$ncMsgList|) + (|ncPutQ| |cc| '|lines| |lines|) + (SETQ |$ncMsgList| NIL) + (SETQ |result| + (|CatchAsCan| |flung| + (|Catch| '|SpadCompileItem| + (CATCH |$intCoerceFailure| + (CATCH |$intSpadReader| + (|intloopSpadProcess,interp| |cc| + |ptree| |interactive?|)))))) + (|intSetNeedToSignalSessionManager|) + (SETQ |$prevCarrier| |$currentCarrier|) + (COND + ((EQ |result| '|ncEnd|) |stepNo|) + ((EQ |result| '|ncError|) |stepNo|) + ((EQ |result| '|ncEndItem|) |stepNo|) + ('T (+ |stepNo| 1))))))) + +(DEFUN |intloopSpadProcess,interp| (|cc| |ptree| |interactive?|) + (PROG () + (RETURN + (PROGN + (|ncConversationPhase| #'|phParse| (LIST |cc| |ptree|)) + (|ncConversationPhase| #'|phMacro| (LIST |cc|)) + (|ncConversationPhase| #'|phIntReportMsgs| + (LIST |cc| |interactive?|)) + (|ncConversationPhase| #'|phInterpret| (LIST |cc|)) + (COND + ((NOT (EQL (LENGTH (|ncEltQ| |cc| '|messages|)) 0)) + (|ncError|))))))) + +;phInterpret carrier == +; ptree := ncEltQ(carrier, 'ptree) +; val := intInterpretPform(ptree) +; ncPutQ(carrier, 'value, val) + +(DEFUN |phInterpret| (|carrier|) + (PROG (|val| |ptree|) + (RETURN + (PROGN + (SETQ |ptree| (|ncEltQ| |carrier| '|ptree|)) + (SETQ |val| (|intInterpretPform| |ptree|)) + (|ncPutQ| |carrier| '|value| |val|))))) + +;--% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] +;phIntReportMsgs(carrier, interactive?) == +; $erMsgToss => 'OK +; lines := ncEltQ(carrier, 'lines) +; msgs := ncEltQ(carrier, 'messages) +; nerr := #msgs +; ncPutQ(carrier, 'ok?, nerr = 0) +; nerr = 0 => 'OK +; processMsgList(msgs, lines) +; intSayKeyedMsg ('S2CTP010,[nerr]) +; 'OK + +(DEFUN |phIntReportMsgs| (|carrier| |interactive?|) + (PROG (|nerr| |msgs| |lines|) + (DECLARE (SPECIAL |$erMsgToss|)) + (RETURN + (COND + (|$erMsgToss| 'OK) + ('T + (PROGN + (SETQ |lines| (|ncEltQ| |carrier| '|lines|)) + (SETQ |msgs| (|ncEltQ| |carrier| '|messages|)) + (SETQ |nerr| (LENGTH |msgs|)) + (|ncPutQ| |carrier| '|ok?| (EQL |nerr| 0)) + (COND + ((EQL |nerr| 0) 'OK) + ('T + (PROGN + (|processMsgList| |msgs| |lines|) + (|intSayKeyedMsg| 'S2CTP010 (LIST |nerr|)) + 'OK))))))))) + +;mkLineList lines == +; l := [CDR line for line in lines | nonBlank CDR line] +; #l = 1 => CAR l +; l + +(DEFUN |mkLineList| (|lines|) + (PROG (|l|) + (RETURN + (PROGN + (SETQ |l| + ((LAMBDA (|bfVar#2| |bfVar#1| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#1|) + (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN (NREVERSE |bfVar#2|))) + ('T + (AND (|nonBlank| (CDR |line|)) + (SETQ |bfVar#2| + (CONS (CDR |line|) |bfVar#2|))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + NIL |lines| NIL)) + (COND ((EQL (LENGTH |l|) 1) (CAR |l|)) ('T |l|)))))) + +;nonBlank str == +; value := false +; for i in 0..MAXINDEX str repeat +; str.i ^= char " " => +; value := true +; return value +; value + +(DEFUN |nonBlank| (|str|) + (PROG (|value|) + (RETURN + (PROGN + (SETQ |value| NIL) + ((LAMBDA (|bfVar#3| |i|) + (LOOP + (COND + ((> |i| |bfVar#3|) (RETURN NIL)) + ('T + (COND + ((NOT (EQUAL (ELT |str| |i|) (|char| '| |))) + (IDENTITY (PROGN (SETQ |value| T) (RETURN |value|))))))) + (SETQ |i| (+ |i| 1)))) + (MAXINDEX |str|) 0) + |value|)))) + +;ncloopDQlines (dq,stream)== +; StreamNull stream +; a:= poGlobalLinePosn tokPosn CADR dq +; b:= poGlobalLinePosn CAAR stream +; streamChop (a-b+1,stream) + +(DEFUN |ncloopDQlines| (|dq| |stream|) + (PROG (|b| |a|) + (RETURN + (PROGN + (|StreamNull| |stream|) + (SETQ |a| (|poGlobalLinePosn| (|tokPosn| (CADR |dq|)))) + (SETQ |b| (|poGlobalLinePosn| (CAAR |stream|))) + (|streamChop| (+ (- |a| |b|) 1) |stream|))))) + +;streamChop(n,s)== +; if StreamNull s +; then [nil,nil] +; else if EQL(n,0) +; then [nil,s] +; else +; [a,b]:= streamChop(n-1,cdr s) +; line:=car s +; c:=ncloopPrefix?('")command",CDR line) +; d:= cons(car line,if c then c else cdr line) +; [cons(d,a),b] + +(DEFUN |streamChop| (|n| |s|) + (PROG (|d| |c| |line| |b| |a| |LETTMP#1|) + (RETURN + (COND + ((|StreamNull| |s|) (LIST NIL NIL)) + ((EQL |n| 0) (LIST NIL |s|)) + ('T (SETQ |LETTMP#1| (|streamChop| (- |n| 1) (CDR |s|))) + (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|)) + (SETQ |line| (CAR |s|)) + (SETQ |c| (|ncloopPrefix?| ")command" (CDR |line|))) + (SETQ |d| + (CONS (CAR |line|) (COND (|c| |c|) ('T (CDR |line|))))) + (LIST (CONS |d| |a|) |b|)))))) + +;ncloopPrintLines lines == +; for line in lines repeat WRITE_-LINE CDR line +; WRITE_-LINE '" " + +(DEFUN |ncloopPrintLines| (|lines|) + (PROG () + (RETURN + (PROGN + ((LAMBDA (|bfVar#4| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#4|) + (PROGN (SETQ |line| (CAR |bfVar#4|)) NIL)) + (RETURN NIL)) + ('T (WRITE-LINE (CDR |line|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))) + |lines| NIL) + (WRITE-LINE " "))))) + +;ncloopParse s== +; [dq,stream]:=CAR s +; [lines,rest]:=ncloopDQlines(dq,stream) +; cons([[lines,npParse dqToList dq]],CDR s) + +(DEFUN |ncloopParse| (|s|) + (PROG (CDR |lines| |stream| |dq| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (CAR |s|)) + (SETQ |dq| (CAR |LETTMP#1|)) + (SETQ |stream| (CADR |LETTMP#1|)) + (SETQ |LETTMP#1| (|ncloopDQlines| |dq| |stream|)) + (SETQ |lines| (CAR |LETTMP#1|)) + (SETQ CDR (CADR |LETTMP#1|)) + (CONS (LIST (LIST |lines| (|npParse| (|dqToList| |dq|)))) + (CDR |s|)))))) + +;ncloopInclude0(st, name, n) == +; $lines:local := incStream(st, name) +; ncloopProcess(n,false, +; next(function ncloopEchoParse, +; next(function insertpile, +; next(function lineoftoks,$lines)))) + +(DEFUN |ncloopInclude0| (|st| |name| |n|) + (PROG (|$lines|) + (DECLARE (SPECIAL |$lines|)) + (RETURN + (PROGN + (SETQ |$lines| (|incStream| |st| |name|)) + (|ncloopProcess| |n| NIL + (|next| #'|ncloopEchoParse| + (|next| #'|insertpile| + (|next| #'|lineoftoks| |$lines|)))))))) + +;incString s== incRenumber incLude(0,[s],0,['"strings"] ,[Top]) + +(DEFUN |incString| (|s|) + (PROG () + (RETURN + (|incRenumber| + (|incLude| 0 (LIST |s|) 0 (LIST "strings") (LIST |Top|)))))) + +;ncError() == +; THROW("SpadCompileItem",'ncError) +; +;--% Compilation Carriers +;-- This data structure is used to carry information between phases. + +(DEFUN |ncError| () + (PROG () (RETURN (THROW '|SpadCompileItem| '|ncError|)))) + +;--% phParse: carrier[tokens,...] -> carrier[ptree, tokens,...] +;--)line (defun pretty (x) (boottran::reallyprettyprint x)) +;--)line (defun packagetran (x) (boot::|packageTran|)) +;phParse(carrier,ptree) == +; phBegin 'Parsing +; if $ncmParse then +; nothing +; intSayKeyedMsg ('S2CTP003,[%pform ptree]) +; ncPutQ(carrier, 'ptree, ptree) +; 'OK + +(DEFUN |phParse| (|carrier| |ptree|) + (PROG () + (DECLARE (SPECIAL |$ncmParse|)) + (RETURN + (PROGN + (|phBegin| '|Parsing|) + (COND + (|$ncmParse| + (|intSayKeyedMsg| 'S2CTP003 (LIST (|%pform| |ptree|))))) + (|ncPutQ| |carrier| '|ptree| |ptree|) + 'OK)))) + +;--% phMacro: carrier[ptree,...] -> carrier[ptree, ptreePremacro,...] +;phMacro carrier == +; phBegin 'Macroing +; ptree := ncEltQ(carrier, 'ptree) +; ncPutQ(carrier, 'ptreePremacro, ptree) +; +; ptree := macroExpanded ptree +; if $ncmMacro then +; intSayKeyedMsg ('S2CTP007,[%pform ptree] ) +; +; ncPutQ(carrier, 'ptree, ptree) +; 'OK + +(DEFUN |phMacro| (|carrier|) + (PROG (|ptree|) + (DECLARE (SPECIAL |$ncmMacro|)) + (RETURN + (PROGN + (|phBegin| '|Macroing|) + (SETQ |ptree| (|ncEltQ| |carrier| '|ptree|)) + (|ncPutQ| |carrier| '|ptreePremacro| |ptree|) + (SETQ |ptree| (|macroExpanded| |ptree|)) + (COND + (|$ncmMacro| + (|intSayKeyedMsg| 'S2CTP007 (LIST (|%pform| |ptree|))))) + (|ncPutQ| |carrier| '|ptree| |ptree|) + 'OK)))) + +;--% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] +;phReportMsgs(carrier, interactive?) == +; $erMsgToss => 'OK +; lines := ncEltQ(carrier, 'lines) +; msgs := ncEltQ(carrier, 'messages) +; nerr := #msgs +; ncPutQ(carrier, 'ok?, nerr = 0) +; interactive? and nerr = 0 => 'OK +; processMsgList(msgs, lines) +; intSayKeyedMsg ('S2CTP010,[nerr]) +; 'OK + +(DEFUN |phReportMsgs| (|carrier| |interactive?|) + (PROG (|nerr| |msgs| |lines|) + (DECLARE (SPECIAL |$erMsgToss|)) + (RETURN + (COND + (|$erMsgToss| 'OK) + ('T + (PROGN + (SETQ |lines| (|ncEltQ| |carrier| '|lines|)) + (SETQ |msgs| (|ncEltQ| |carrier| '|messages|)) + (SETQ |nerr| (LENGTH |msgs|)) + (|ncPutQ| |carrier| '|ok?| (EQL |nerr| 0)) + (COND + ((AND |interactive?| (EQL |nerr| 0)) 'OK) + ('T + (PROGN + (|processMsgList| |msgs| |lines|) + (|intSayKeyedMsg| 'S2CTP010 (LIST |nerr|)) + 'OK))))))))) + +;ncConversationPhase(fn, args) == +; carrier := first args +; +; $ncMsgList: local := [] +; $convPhase: local := 'NoPhase +; +; UNWIND_-PROTECT( APPLY(fn, args), wrapup(carrier) ) where +; wrapup(carrier) == +; for m in $ncMsgList repeat +; ncPutQ(carrier, 'messages, [m, :ncEltQ(carrier, 'messages)]) + +(DEFUN |ncConversationPhase| (|fn| |args|) + (PROG (|$convPhase| |$ncMsgList| |carrier|) + (DECLARE (SPECIAL |$convPhase| |$ncMsgList|)) + (RETURN + (PROGN + (SETQ |carrier| (CAR |args|)) + (SETQ |$ncMsgList| NIL) + (SETQ |$convPhase| '|NoPhase|) + (UNWIND-PROTECT + (APPLY |fn| |args|) + (|ncConversationPhase,wrapup| |carrier|)))))) + +(DEFUN |ncConversationPhase,wrapup| (|carrier|) + (PROG () + (DECLARE (SPECIAL |$ncMsgList|)) + (RETURN + ((LAMBDA (|bfVar#5| |m|) + (LOOP + (COND + ((OR (ATOM |bfVar#5|) + (PROGN (SETQ |m| (CAR |bfVar#5|)) NIL)) + (RETURN NIL)) + ('T + (|ncPutQ| |carrier| '|messages| + (CONS |m| (|ncEltQ| |carrier| '|messages|))))) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + |$ncMsgList| NIL)))) + +;phBegin id == +; $convPhase := id +; if $ncmPhase then intSayKeyedMsg('S2CTP021,[id]) + +(DEFUN |phBegin| (|id|) + (PROG () + (DECLARE (SPECIAL |$ncmPhase| |$convPhase|)) + (RETURN + (PROGN + (SETQ |$convPhase| |id|) + (COND (|$ncmPhase| (|intSayKeyedMsg| 'S2CTP021 (LIST |id|)))))))) + +;PullAndExecuteSpadSystemCommand stream == +; ExecuteSpadSystemCommand CAR stream +; CDR stream + +(DEFUN |PullAndExecuteSpadSystemCommand| (|stream|) + (PROG () + (RETURN + (PROGN + (|ExecuteSpadSystemCommand| (CAR |stream|)) + (CDR |stream|))))) + +;ExecuteSpadSystemCommand string == +; FUNCALL($systemCommandFunction, string) + +(DEFUN |ExecuteSpadSystemCommand| (|string|) + (PROG () + (DECLARE (SPECIAL |$systemCommandFunction|)) + (RETURN (FUNCALL |$systemCommandFunction| |string|)))) + +@ +\eject +\begin{thebibliography}{99} +\end{thebibliography} +\end{document}