diff options
Diffstat (limited to 'src/boot/scanner.boot.pamphlet')
-rw-r--r-- | src/boot/scanner.boot.pamphlet | 1163 |
1 files changed, 0 insertions, 1163 deletions
diff --git a/src/boot/scanner.boot.pamphlet b/src/boot/scanner.boot.pamphlet deleted file mode 100644 index b6bc1175..00000000 --- a/src/boot/scanner.boot.pamphlet +++ /dev/null @@ -1,1163 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/boot/scanner.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<<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. - -@ - -<<*>>= -<<license>> - -module '"boot-lexer" -import '"tokens" -import '"includer" - -)package "BOOTTRAN" - --- converts X to double-float. -double x == - FLOAT(x, 1.0) - -dqUnit s==(a:=[s];CONS(a,a)) - -dqAppend(x,y)== - if null x - then y - else if null y - then x - else - RPLACD (CDR x,CAR y) - RPLACD (x, CDR y) - x - -dqConcat ld== - if null ld - then nil - else if null rest ld - then first ld - else dqAppend(first ld,dqConcat rest ld) - -dqToList s==if null s then nil else CAR s - -shoeConstructToken(ln,lp,b,n)==[b.0,b.1,:cons(lp,n)] -shoeTokType x== CAR x -shoeTokPart x== CADR x -shoeTokPosn x== CDDR x -shoeTokConstruct(x,y,z)==[x,y,:z] - -shoeNextLine(s)== - if bStreamNull s - then false - else - $linepos:=s - $f:= CAR s - $r:= CDR s - $ln:=CAR $f - $n:=STRPOSL('" ",$ln,0,true) - $sz :=# $ln - null $n => true - QENUM($ln,$n)=shoeTAB => - a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ") - $ln.$n:='" ".0 - $ln:=CONCAT(a,$ln) - s1:=cons(cons($ln,CDR $f),$r) - shoeNextLine s1 - true - -shoeLineToks(s)== - $f: local:=nil - $r:local :=nil - $ln:local :=nil - $n:local:=nil - $sz:local := nil - $floatok:local:=true - $linepos:local:=s - not shoeNextLine s => CONS(nil,nil) - null $n => shoeLineToks $r - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLine? $ln=> - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLine command,0) - cons([dq],$r) - command:=shoeLisp? $ln=> shoeLispToken($r,command) - command:=shoePackage? $ln=> - -- z:=car shoeBiteOff command - a:=CONCAT('"(IN-PACKAGE ",command,'")") - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLisp a,0) - cons([dq],$r) - shoeLineToks $r - toks:=[] - while $n<$sz repeat toks:=dqAppend(toks,shoeToken()) - null toks => shoeLineToks $r - cons([toks],$r) - -shoeLispToken(s,string)== - string:= - # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '"" - string - ln:=$ln - linepos:=$linepos - [r,:st]:=shoeAccumulateLines(s,string) - dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0) - cons([dq],r) - -shoeAccumulateLines(s,string)== - not shoeNextLine s => CONS(s,string) - null $n => shoeAccumulateLines($r,string) - # $ln=0 => shoeAccumulateLines($r,string) - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLisp? $ln - command and #command>0 => - EQL(QENUM(command,0),QENUM('";",0))=> - shoeAccumulateLines($r,string) - a:=STRPOS('";",command,0,nil) - a=> - shoeAccumulateLines($r, - CONCAT(string,SUBSTRING(command,0,a-1))) - shoeAccumulateLines($r,CONCAT(string,command)) - shoeAccumulateLines($r,string) - CONS(s,string) - --- returns true if token t is closing `parenthesis'. -shoeCloser t == - MEMQ(shoeKeyWord t, '(CPAREN CBRACK)) - -shoeToken () == - ln:=$ln - c:=QENUM($ln,$n) - linepos:=$linepos - n:=$n - ch:=$ln.$n - b:= - shoeStartsComment() => - shoeComment() - [] - shoeStartsNegComment() => - shoeNegComment() - [] - c=shoeLispESCAPE => - shoeLispEscape() - shoePunctuation c => shoePunct () - shoeStartsId ch => shoeWord (false) - c=shoeSPACE => - shoeSpace () - [] - c = shoeSTRING_CHAR => shoeString () - shoeDigit ch => shoeNumber () - c=shoeESCAPE => shoeEscape() - c=shoeTAB => - $n:=$n+1 - [] - shoeError () - null b => nil - dqUnit shoeConstructToken(ln,linepos,b,n) - --- to pair badge and badgee -shoeLeafId x== ["ID",INTERN x] - -shoeLeafKey x==["KEY",shoeKeyWord x] - -shoeLeafInteger x==["INTEGER",shoeIntValue x] - -shoeLeafFloat(a,w,e)== - b:=shoeIntValue CONCAT(a,w) - c:= double b * EXPT(double 10, e-#w) - ["FLOAT",c] - -shoeLeafString x == ["STRING",x] - -shoeLeafLisp x == ["LISP",x] -shoeLeafLispExp x == ["LISPEXP",x] - -shoeLeafLine x == ["LINE",x] - -shoeLeafComment x == ["COMMENT", x] - -shoeLeafNegComment x== ["NEGCOMMENT", x] - -shoeLeafError x == ["ERROR",x] - -shoeLeafSpaces x == ["SPACES",x] - -shoeLispEscape()== - $n:=$n+1 - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - else - a:=shoeReadLispString($ln,$n) - null a => - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - [exp,n]:=a - null n => - $n:= $sz - shoeLeafLispExp exp - $n:=n - shoeLeafLispExp exp -shoeEscape()== - $n:=$n+1 - a:=shoeEsc() - if a then shoeWord true else nil - -shoeEsc()== - if $n>=$sz - then if shoeNextLine($r) - then - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else false - else - n1:=STRPOSL('" ",$ln,$n,true) - if null n1 - then - shoeNextLine($r) - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else true - -shoeStartsComment()== - if $n<$sz - then - if QENUM($ln,$n)=shoePLUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoePLUSCOMMENT - else false - else false - -shoeStartsNegComment()== - if $n< $sz - then - if QENUM($ln,$n)=shoeMINUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoeMINUSCOMMENT - else false - else false - -shoeNegComment()== - n:=$n - $n:=$sz - shoeLeafNegComment SUBSTRING($ln,n,nil) - -shoeComment()== - n:=$n - $n:=$sz - shoeLeafComment SUBSTRING($ln,n,nil) - -shoePunct()== - sss:=shoeMatch($ln,$n) - $n:=$n+#sss - shoeKeyTr sss - -shoeKeyTr w== - if EQ(shoeKeyWord w,"DOT") - then if $floatok - then shoePossFloat(w) - else shoeLeafKey w - else - $floatok:=not shoeCloser w - shoeLeafKey w - -shoePossFloat (w)== - if $n>=$sz or not shoeDigit $ln.$n - then shoeLeafKey w - else - w:=shoeInteger() - shoeExponent('"0",w) - - -shoeSpace()== - n:=$n - $n:=STRPOSL('" ",$ln,$n,true) - $floatok:=true - if null $n - then - shoeLeafSpaces 0 - $n:= # $ln - else shoeLeafSpaces ($n-n) - -shoeString()== - $n:=$n+1 - $floatok:=false - shoeLeafString shoeS () - -shoeS()== - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"quote added") - '"" - else - n:=$n - strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz - escsym:=STRPOS ('"__" - ,$ln,$n,nil) or $sz - mn:=MIN(strsym,escsym) - if mn=$sz - then - $n:=$sz - SoftShoeError(cons($linepos,$n),'"quote added") - SUBSTRING($ln,n,nil) - else if mn=strsym - then - $n:=mn+1 - SUBSTRING($ln,n,mn-n) - else - str:=SUBSTRING($ln,n,mn-n) - $n:=mn+1 - a:=shoeEsc() - b:=if a - then - str:=CONCAT(str,$ln.$n) - $n:=$n+1 - shoeS() - else shoeS() - CONCAT(str,b) - - - - -shoeIdEnd(line,n)== - while n<#line and shoeIdChar line.n repeat n:=n+1 - n - - -shoeDigit x== DIGIT_-CHAR_-P x - -shoeW(b)== - n1:=$n - $n:=$n+1 - l:=$sz - endid:=shoeIdEnd($ln,$n) - if endid=l or QENUM($ln,endid)^=shoeESCAPE - then - $n:=endid - [b,SUBSTRING($ln,n1,endid-n1)] - else - str:=SUBSTRING($ln,n1,endid-n1) - $n:=endid+1 - a:=shoeEsc() - bb:=if a - then shoeW(true) - else [b,'""] -- escape finds space or newline - [bb.0 or b,CONCAT(str,bb.1)] - -shoeWord(esp) == - aaa:=shoeW(false) - w:=aaa.1 - $floatok:=false - if esp or aaa.0 - then shoeLeafId w - else if shoeKeyWordP w - then - $floatok:=true - shoeLeafKey w - else shoeLeafId w - -shoeInteger()==shoeInteger1(false) - -shoeInteger1(zro) == - n:=$n - l:= $sz - while $n<l and shoeDigit($ln.$n) repeat $n:=$n+1 - if $n=l or QENUM($ln,$n)^=shoeESCAPE - then if n=$n and zro - then '"0" - else SUBSTRING($ln,n,$n-n) - else - str:=SUBSTRING($ln,n,$n-n) - $n:=$n+1 - a:=shoeEsc() - bb:=shoeInteger1(zro) - CONCAT(str,bb) - -shoeIntValue(s) == - ns := #s - ival := 0 - for i in 0..ns-1 repeat - d := shoeOrdToNum ELT(s,i) - ival := 10*ival + d - ival - -shoeNumber() == - a := shoeInteger() - if $n>=$sz - then shoeLeafInteger a - else - if $floatok and QENUM($ln,$n)=shoeDOT - then - n:=$n - $n:=$n+1 - if $n<$sz and QENUM($ln,$n)=shoeDOT - then - $n:=n - shoeLeafInteger a - else - w:=shoeInteger1(true) - shoeExponent(a,w) - else shoeLeafInteger a - -shoeExponent(a,w)== - if $n>=$sz - then shoeLeafFloat(a,w,0) - else - n:=$n - c:=QENUM($ln,$n) - if c=shoeEXPONENT1 or c=shoeEXPONENT2 - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w,e) - else - c1:=QENUM($ln,$n) - if c1=shoePLUSCOMMENT or c1=shoeMINUSCOMMENT - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else - if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w, - (if c1=shoeMINUSCOMMENT then MINUS e else e)) - else - $n:=n - shoeLeafFloat(a,w,0) - else shoeLeafFloat(a,w,0) - -shoeError()== - n:=$n - $n:=$n+1 - SoftShoeError(cons($linepos,n), - CONCAT( '"The character whose number is ", - STRINGIMAGE QENUM($ln,n),'" is not a Boot character")) - shoeLeafError ($ln.n) - -shoeOrdToNum x== DIGIT_-CHAR_-P x - -shoeKeyWord st == GETHASH(st,shoeKeyTable) - -shoeKeyWordP st == not null GETHASH(st,shoeKeyTable) - -shoeMatch(l,i)==shoeSubStringMatch(l,shoeDict,i) - -shoeSubStringMatch (l,d,i)== - h:= QENUM(l, i) - u:=ELT(d,h) - ll:=SIZE l - done:=false - s1:='"" - for j in 0.. SIZE u - 1 while not done repeat - s:=ELT(u,j) - ls:=SIZE s - done:=if ls+i > ll - then false - else - eql:= true - for k in 1..ls-1 while eql repeat - eql:= EQL(QENUM(s,k),QENUM(l,k+i)) - if eql - then - s1:=s - true - else false - s1 - -shoePunctuation c== shoePun.c =1 - -@ -<<scanner.clisp>>= -(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-lexer")) - -(IMPORT-MODULE "tokens") - -(IMPORT-MODULE "includer") - -(IN-PACKAGE "BOOTTRAN") - -(DEFUN |double| (|x|) (PROG () (RETURN (FLOAT |x| 1.0)))) - -(DEFUN |dqUnit| (|s|) - (PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))) - -(DEFUN |dqAppend| (|x| |y|) - (PROG () - (RETURN - (COND - ((NULL |x|) |y|) - ((NULL |y|) |x|) - ('T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|))))) - -(DEFUN |dqConcat| (|ld|) - (PROG () - (RETURN - (COND - ((NULL |ld|) NIL) - ((NULL (CDR |ld|)) (CAR |ld|)) - ('T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))))) - -(DEFUN |dqToList| (|s|) - (PROG () (RETURN (COND ((NULL |s|) NIL) ('T (CAR |s|)))))) - -(DEFUN |shoeConstructToken| (|ln| |lp| |b| |n|) - (PROG () - (RETURN (CONS (ELT |b| 0) (CONS (ELT |b| 1) (CONS |lp| |n|)))))) - -(DEFUN |shoeTokType| (|x|) (PROG () (RETURN (CAR |x|)))) - -(DEFUN |shoeTokPart| (|x|) (PROG () (RETURN (CADR |x|)))) - -(DEFUN |shoeTokPosn| (|x|) (PROG () (RETURN (CDDR |x|)))) - -(DEFUN |shoeTokConstruct| (|x| |y| |z|) - (PROG () (RETURN (CONS |x| (CONS |y| |z|))))) - -(DEFUN |shoeNextLine| (|s|) - (PROG (|s1| |a|) - (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) - (RETURN - (COND - ((|bStreamNull| |s|) NIL) - ('T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) - (SETQ |$r| (CDR |s|)) (SETQ |$ln| (CAR |$f|)) - (SETQ |$n| (STRPOSL " " |$ln| 0 T)) - (SETQ |$sz| (LENGTH |$ln|)) - (COND - ((NULL |$n|) T) - ((EQUAL (QENUM |$ln| |$n|) |shoeTAB|) - (PROGN - (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " ")) - (SETF (ELT |$ln| |$n|) (ELT " " 0)) - (SETQ |$ln| (CONCAT |a| |$ln|)) - (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) - (|shoeNextLine| |s1|))) - ('T T))))))) - -(DEFUN |shoeLineToks| (|s|) - (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |a| - |dq| |command| |fst|) - (DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|)) - (RETURN - (PROGN - (SETQ |$f| NIL) - (SETQ |$r| NIL) - (SETQ |$ln| NIL) - (SETQ |$n| NIL) - (SETQ |$sz| NIL) - (SETQ |$floatok| T) - (SETQ |$linepos| |s|) - (COND - ((NULL (|shoeNextLine| |s|)) (CONS NIL NIL)) - ((NULL |$n|) (|shoeLineToks| |$r|)) - (#0='T - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) - (COND - ((SETQ |command| (|shoeLine?| |$ln|)) - (PROGN - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |$ln| |$linepos| - (|shoeLeafLine| |command|) 0))) - (CONS (LIST |dq|) |$r|))) - ((SETQ |command| (|shoeLisp?| |$ln|)) - (|shoeLispToken| |$r| |command|)) - ((SETQ |command| (|shoePackage?| |$ln|)) - (PROGN - (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |$ln| |$linepos| - (|shoeLeafLisp| |a|) 0))) - (CONS (LIST |dq|) |$r|))) - (#0# (|shoeLineToks| |$r|)))) - (#0# - (PROGN - (SETQ |toks| NIL) - (LOOP - (COND - ((NOT (< |$n| |$sz|)) (RETURN NIL)) - ('T - (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) - (COND - ((NULL |toks|) (|shoeLineToks| |$r|)) - (#0# (CONS (LIST |toks|) |$r|))))))))))))) - -(DEFUN |shoeLispToken| (|s| |string|) - (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) - (DECLARE (SPECIAL |$linepos| |$ln|)) - (RETURN - (PROGN - (SETQ |string| - (COND - ((OR (EQL (LENGTH |string|) 0) - (EQL (QENUM |string| 0) (QENUM ";" 0))) - "") - ('T |string|))) - (SETQ |ln| |$ln|) - (SETQ |linepos| |$linepos|) - (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|)) - (SETQ |r| (CAR |LETTMP#1|)) - (SETQ |st| (CDR |LETTMP#1|)) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |ln| |linepos| - (|shoeLeafLisp| |st|) 0))) - (CONS (LIST |dq|) |r|))))) - -(DEFUN |shoeAccumulateLines| (|s| |string|) - (PROG (|a| |command| |fst|) - (DECLARE (SPECIAL |$ln| |$r| |$n|)) - (RETURN - (COND - ((NULL (|shoeNextLine| |s|)) (CONS |s| |string|)) - ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) - ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) - (#0='T - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) - (PROGN - (SETQ |command| (|shoeLisp?| |$ln|)) - (COND - ((AND |command| (< 0 (LENGTH |command|))) - (COND - ((EQL (QENUM |command| 0) (QENUM ";" 0)) - (|shoeAccumulateLines| |$r| |string|)) - (#0# - (PROGN - (SETQ |a| (STRPOS ";" |command| 0 NIL)) - (COND - (|a| (|shoeAccumulateLines| |$r| - (CONCAT |string| - (SUBSTRING |command| 0 (- |a| 1))))) - (#0# - (|shoeAccumulateLines| |$r| - (CONCAT |string| |command|)))))))) - (#0# (|shoeAccumulateLines| |$r| |string|))))) - (#0# (CONS |s| |string|))))))))) - -(DEFUN |shoeCloser| (|t|) - (PROG () (RETURN (MEMQ (|shoeKeyWord| |t|) '(CPAREN CBRACK))))) - -(DEFUN |shoeToken| () - (PROG (|b| |ch| |n| |linepos| |c| |ln|) - (DECLARE (SPECIAL |$linepos| |$n| |$ln|)) - (RETURN - (PROGN - (SETQ |ln| |$ln|) - (SETQ |c| (QENUM |$ln| |$n|)) - (SETQ |linepos| |$linepos|) - (SETQ |n| |$n|) - (SETQ |ch| (ELT |$ln| |$n|)) - (SETQ |b| - (COND - ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL)) - ((|shoeStartsNegComment|) - (PROGN (|shoeNegComment|) NIL)) - ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|)) - ((|shoePunctuation| |c|) (|shoePunct|)) - ((|shoeStartsId| |ch|) (|shoeWord| NIL)) - ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL)) - ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|)) - ((|shoeDigit| |ch|) (|shoeNumber|)) - ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|)) - ((EQUAL |c| |shoeTAB|) - (PROGN (SETQ |$n| (+ |$n| 1)) NIL)) - (#0='T (|shoeError|)))) - (COND - ((NULL |b|) NIL) - (#0# - (|dqUnit| (|shoeConstructToken| |ln| |linepos| |b| |n|)))))))) - -(DEFUN |shoeLeafId| (|x|) (PROG () (RETURN (LIST 'ID (INTERN |x|))))) - -(DEFUN |shoeLeafKey| (|x|) - (PROG () (RETURN (LIST 'KEY (|shoeKeyWord| |x|))))) - -(DEFUN |shoeLeafInteger| (|x|) - (PROG () (RETURN (LIST 'INTEGER (|shoeIntValue| |x|))))) - -(DEFUN |shoeLeafFloat| (|a| |w| |e|) - (PROG (|c| |b|) - (RETURN - (PROGN - (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|))) - (SETQ |c| - (* (|double| |b|) - (EXPT (|double| 10) (- |e| (LENGTH |w|))))) - (LIST 'FLOAT |c|))))) - -(DEFUN |shoeLeafString| (|x|) (PROG () (RETURN (LIST 'STRING |x|)))) - -(DEFUN |shoeLeafLisp| (|x|) (PROG () (RETURN (LIST 'LISP |x|)))) - -(DEFUN |shoeLeafLispExp| (|x|) (PROG () (RETURN (LIST 'LISPEXP |x|)))) - -(DEFUN |shoeLeafLine| (|x|) (PROG () (RETURN (LIST 'LINE |x|)))) - -(DEFUN |shoeLeafComment| (|x|) (PROG () (RETURN (LIST 'COMMENT |x|)))) - -(DEFUN |shoeLeafNegComment| (|x|) - (PROG () (RETURN (LIST 'NEGCOMMENT |x|)))) - -(DEFUN |shoeLeafError| (|x|) (PROG () (RETURN (LIST 'ERROR |x|)))) - -(DEFUN |shoeLeafSpaces| (|x|) (PROG () (RETURN (LIST 'SPACES |x|)))) - -(DEFUN |shoeLispEscape| () - (PROG (|n| |exp| |a|) - (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |$n| (+ |$n| 1)) - (COND - ((NOT (< |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") - (|shoeLeafError| (ELT |$ln| |$n|))) - ('T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) - (COND - ((NULL |a|) - (PROGN - (|SoftShoeError| (CONS |$linepos| |$n|) - "lisp escape error") - (|shoeLeafError| (ELT |$ln| |$n|)))) - (#0='T - (PROGN - (SETQ |exp| (CAR |a|)) - (SETQ |n| (CADR |a|)) - (COND - ((NULL |n|) - (PROGN (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))) - (#0# - (PROGN (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))))) - -(DEFUN |shoeEscape| () - (PROG (|a|) - (DECLARE (SPECIAL |$n|)) - (RETURN - (PROGN - (SETQ |$n| (+ |$n| 1)) - (SETQ |a| (|shoeEsc|)) - (COND (|a| (|shoeWord| T)) ('T NIL)))))) - -(DEFUN |shoeEsc| () - (PROG (|n1|) - (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|)) - (RETURN - (COND - ((NOT (< |$n| |$sz|)) - (COND - ((|shoeNextLine| |$r|) - (LOOP - (COND (|$n| (RETURN NIL)) (#0='T (|shoeNextLine| |$r|)))) - (|shoeEsc|) NIL) - (#1='T NIL))) - (#1# (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) - (COND - ((NULL |n1|) (|shoeNextLine| |$r|) - (LOOP - (COND (|$n| (RETURN NIL)) (#0# (|shoeNextLine| |$r|)))) - (|shoeEsc|) NIL) - (#1# T))))))) - -(DEFUN |shoeStartsComment| () - (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((< |$n| |$sz|) - (COND - ((EQUAL (QENUM |$ln| |$n|) |shoePLUSCOMMENT|) - (SETQ |www| (+ |$n| 1)) - (COND - ((NOT (< |www| |$sz|)) NIL) - (#0='T (EQUAL (QENUM |$ln| |www|) |shoePLUSCOMMENT|)))) - (#0# NIL))) - (#0# NIL))))) - -(DEFUN |shoeStartsNegComment| () - (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((< |$n| |$sz|) - (COND - ((EQUAL (QENUM |$ln| |$n|) |shoeMINUSCOMMENT|) - (SETQ |www| (+ |$n| 1)) - (COND - ((NOT (< |www| |$sz|)) NIL) - (#0='T (EQUAL (QENUM |$ln| |www|) |shoeMINUSCOMMENT|)))) - (#0# NIL))) - (#0# NIL))))) - -(DEFUN |shoeNegComment| () - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafNegComment| (SUBSTRING |$ln| |n| NIL)))))) - -(DEFUN |shoeComment| () - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafComment| (SUBSTRING |$ln| |n| NIL)))))) - -(DEFUN |shoePunct| () - (PROG (|sss|) - (DECLARE (SPECIAL |$n| |$ln|)) - (RETURN - (PROGN - (SETQ |sss| (|shoeMatch| |$ln| |$n|)) - (SETQ |$n| (+ |$n| (LENGTH |sss|))) - (|shoeKeyTr| |sss|))))) - -(DEFUN |shoeKeyTr| (|w|) - (PROG () - (DECLARE (SPECIAL |$floatok|)) - (RETURN - (COND - ((EQ (|shoeKeyWord| |w|) 'DOT) - (COND - (|$floatok| (|shoePossFloat| |w|)) - (#0='T (|shoeLeafKey| |w|)))) - (#0# (SETQ |$floatok| (NULL (|shoeCloser| |w|))) - (|shoeLeafKey| |w|)))))) - -(DEFUN |shoePossFloat| (|w|) - (PROG () - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((OR (NOT (< |$n| |$sz|)) - (NULL (|shoeDigit| (ELT |$ln| |$n|)))) - (|shoeLeafKey| |w|)) - ('T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))))) - -(DEFUN |shoeSpace| () - (PROG (|n|) - (DECLARE (SPECIAL |$floatok| |$ln| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| (STRPOSL " " |$ln| |$n| T)) - (SETQ |$floatok| T) - (COND - ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|))) - ('T (|shoeLeafSpaces| (- |$n| |n|)))))))) - -(DEFUN |shoeString| () - (PROG () - (DECLARE (SPECIAL |$floatok| |$n|)) - (RETURN - (PROGN - (SETQ |$n| (+ |$n| 1)) - (SETQ |$floatok| NIL) - (|shoeLeafString| (|shoeS|)))))) - -(DEFUN |shoeS| () - (PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|) - (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) - (RETURN - (COND - ((NOT (< |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") - (#0='T (SETQ |n| |$n|) - (SETQ |strsym| (OR (STRPOS "\"" |$ln| |$n| NIL) |$sz|)) - (SETQ |escsym| (OR (STRPOS "_" |$ln| |$n| NIL) |$sz|)) - (SETQ |mn| (MIN |strsym| |escsym|)) - (COND - ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") - (SUBSTRING |$ln| |n| NIL)) - ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1)) - (SUBSTRING |$ln| |n| (- |mn| |n|))) - (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |mn| |n|))) - (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |b| - (COND - (|a| (SETQ |str| (CONCAT |str| (ELT |$ln| |$n|))) - (SETQ |$n| (+ |$n| 1)) (|shoeS|)) - (#0# (|shoeS|)))) - (CONCAT |str| |b|)))))))) - -(DEFUN |shoeIdEnd| (|line| |n|) - (PROG () - (RETURN - (PROGN - (LOOP - (COND - ((NOT (AND (< |n| (LENGTH |line|)) - (|shoeIdChar| (ELT |line| |n|)))) - (RETURN NIL)) - ('T (SETQ |n| (+ |n| 1))))) - |n|)))) - -(DEFUN |shoeDigit| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) - -(DEFUN |shoeW| (|b|) - (PROG (|bb| |a| |str| |endid| |l| |n1|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n1| |$n|) - (SETQ |$n| (+ |$n| 1)) - (SETQ |l| |$sz|) - (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) - (COND - ((OR (EQUAL |endid| |l|) - (NOT (EQUAL (QENUM |$ln| |endid|) |shoeESCAPE|))) - (SETQ |$n| |endid|) - (LIST |b| (SUBSTRING |$ln| |n1| (- |endid| |n1|)))) - (#0='T (SETQ |str| (SUBSTRING |$ln| |n1| (- |endid| |n1|))) - (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (COND (|a| (|shoeW| T)) (#0# (LIST |b| "")))) - (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))) - -(DEFUN |shoeWord| (|esp|) - (PROG (|w| |aaa|) - (DECLARE (SPECIAL |$floatok|)) - (RETURN - (PROGN - (SETQ |aaa| (|shoeW| NIL)) - (SETQ |w| (ELT |aaa| 1)) - (SETQ |$floatok| NIL) - (COND - ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|)) - ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) - (|shoeLeafKey| |w|)) - ('T (|shoeLeafId| |w|))))))) - -(DEFUN |shoeInteger| () (PROG () (RETURN (|shoeInteger1| NIL)))) - -(DEFUN |shoeInteger1| (|zro|) - (PROG (|bb| |a| |str| |l| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |l| |$sz|) - (LOOP - (COND - ((NOT (AND (< |$n| |l|) (|shoeDigit| (ELT |$ln| |$n|)))) - (RETURN NIL)) - ('T (SETQ |$n| (+ |$n| 1))))) - (COND - ((OR (EQUAL |$n| |l|) - (NOT (EQUAL (QENUM |$ln| |$n|) |shoeESCAPE|))) - (COND - ((AND (EQUAL |n| |$n|) |zro|) "0") - (#0='T (SUBSTRING |$ln| |n| (- |$n| |n|))))) - (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |$n| |n|))) - (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|))))))) - -(DEFUN |shoeIntValue| (|s|) - (PROG (|d| |ival| |ns|) - (RETURN - (PROGN - (SETQ |ns| (LENGTH |s|)) - (SETQ |ival| 0) - (LET ((|bfVar#1| (- |ns| 1)) (|i| 0)) - (LOOP - (COND - ((> |i| |bfVar#1|) (RETURN NIL)) - ('T - (PROGN - (SETQ |d| (|shoeOrdToNum| (ELT |s| |i|))) - (SETQ |ival| (+ (* 10 |ival|) |d|))))) - (SETQ |i| (+ |i| 1)))) - |ival|)))) - -(DEFUN |shoeNumber| () - (PROG (|w| |n| |a|) - (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |a| (|shoeInteger|)) - (COND - ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|)) - ((AND |$floatok| (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) - (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1)) - (COND - ((AND (< |$n| |$sz|) (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) - (SETQ |$n| |n|) (|shoeLeafInteger| |a|)) - (#0='T (SETQ |w| (|shoeInteger1| T)) - (|shoeExponent| |a| |w|)))) - (#0# (|shoeLeafInteger| |a|))))))) - -(DEFUN |shoeExponent| (|a| |w|) - (PROG (|c1| |e| |c| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0)) - (#0='T (SETQ |n| |$n|) (SETQ |c| (QENUM |$ln| |$n|)) - (COND - ((OR (EQUAL |c| |shoeEXPONENT1|) - (EQUAL |c| |shoeEXPONENT2|)) - (SETQ |$n| (+ |$n| 1)) - (COND - ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((|shoeDigit| (ELT |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| |a| |w| |e|)) - (#0# (SETQ |c1| (QENUM |$ln| |$n|)) - (COND - ((OR (EQUAL |c1| |shoePLUSCOMMENT|) - (EQUAL |c1| |shoeMINUSCOMMENT|)) - (SETQ |$n| (+ |$n| 1)) - (COND - ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((|shoeDigit| (ELT |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| |a| |w| - (COND - ((EQUAL |c1| |shoeMINUSCOMMENT|) (- |e|)) - (#0# |e|)))) - (#0# (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) - (#0# (|shoeLeafFloat| |a| |w| 0)))))))) - -(DEFUN |shoeError| () - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$linepos| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| (+ |$n| 1)) - (|SoftShoeError| (CONS |$linepos| |n|) - (CONCAT "The character whose number is " - (STRINGIMAGE (QENUM |$ln| |n|)) - " is not a Boot character")) - (|shoeLeafError| (ELT |$ln| |n|)))))) - -(DEFUN |shoeOrdToNum| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) - -(DEFUN |shoeKeyWord| (|st|) - (PROG () (RETURN (GETHASH |st| |shoeKeyTable|)))) - -(DEFUN |shoeKeyWordP| (|st|) - (PROG () (RETURN (NULL (NULL (GETHASH |st| |shoeKeyTable|)))))) - -(DEFUN |shoeMatch| (|l| |i|) - (PROG () (RETURN (|shoeSubStringMatch| |l| |shoeDict| |i|)))) - -(DEFUN |shoeSubStringMatch| (|l| |d| |i|) - (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|) - (RETURN - (PROGN - (SETQ |h| (QENUM |l| |i|)) - (SETQ |u| (ELT |d| |h|)) - (SETQ |ll| (SIZE |l|)) - (SETQ |done| NIL) - (SETQ |s1| "") - (LET ((|bfVar#2| (- (SIZE |u|) 1)) (|j| 0)) - (LOOP - (COND - ((OR (> |j| |bfVar#2|) |done|) (RETURN NIL)) - (#0='T - (PROGN - (SETQ |s| (ELT |u| |j|)) - (SETQ |ls| (SIZE |s|)) - (SETQ |done| - (COND - ((< |ll| (+ |ls| |i|)) NIL) - (#1='T (SETQ |eql| T) - (LET ((|bfVar#3| (- |ls| 1)) (|k| 1)) - (LOOP - (COND - ((OR (> |k| |bfVar#3|) (NOT |eql|)) - (RETURN NIL)) - (#0# - (SETQ |eql| - (EQL (QENUM |s| |k|) - (QENUM |l| (+ |k| |i|)))))) - (SETQ |k| (+ |k| 1)))) - (COND (|eql| (SETQ |s1| |s|) T) (#1# NIL)))))))) - (SETQ |j| (+ |j| 1)))) - |s1|)))) - -(DEFUN |shoePunctuation| (|c|) - (PROG () (RETURN (EQL (ELT |shoePun| |c|) 1)))) - -@ - -\end{document} |