aboutsummaryrefslogtreecommitdiff
path: root/src/boot/pile.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/pile.boot.pamphlet')
-rw-r--r--src/boot/pile.boot.pamphlet325
1 files changed, 325 insertions, 0 deletions
diff --git a/src/boot/pile.boot.pamphlet b/src/boot/pile.boot.pamphlet
new file mode 100644
index 00000000..eaad129f
--- /dev/null
+++ b/src/boot/pile.boot.pamphlet
@@ -0,0 +1,325 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/boot/pile.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-pile"
+import '"includer"
+import '"scanner"
+
+)package "BOOTTRAN"
+shoeFirstTokPosn t== shoeTokPosn CAAR t
+shoeLastTokPosn t== shoeTokPosn CADR t
+shoePileColumn t==CDR shoeTokPosn CAAR t
+
+-- s is a token-dq-stream
+
+shoePileInsert (s)==
+ if bStreamNull s
+ then cons([],s)
+ else
+ toktype:=shoeTokType CAAAR s
+ if toktype ="LISP" or toktype = "LINE"
+ then cons([car s],cdr s)
+ else
+ a:=shoePileTree(-1,s)
+ cons([a.2],a.3)
+
+shoePileTree(n,s)==
+ if bStreamNull s
+ then [false,n,[],s]
+ else
+ [h,t]:=[car s,cdr s]
+ hh:=shoePileColumn h
+ if hh > n
+ then shoePileForests(h,hh,t)
+ else [false,n,[],s]
+
+eqshoePileTree(n,s)==
+ if bStreamNull s
+ then [false,n,[],s]
+ else
+ [h,t]:=[car s,cdr s]
+ hh:=shoePileColumn h
+ if hh = n
+ then shoePileForests(h,hh,t)
+ else [false,n,[],s]
+
+shoePileForest(n,s)==
+ [b,hh,h,t]:= shoePileTree(n,s)
+ if b
+ then
+ [h1,t1]:=shoePileForest1(hh,t)
+ [cons(h,h1),t1]
+ else [[],s]
+
+shoePileForest1(n,s)==
+ [b,n1,h,t]:= eqshoePileTree(n,s)
+ if b
+ then
+ [h1,t1]:=shoePileForest1(n,t)
+ [cons(h,h1),t1]
+ else [[],s]
+
+shoePileForests(h,n,s)==
+ [h1,t1]:=shoePileForest(n,s)
+ if bStreamNull h1
+ then [true,n,h,s]
+ else shoePileForests(shoePileCtree(h,h1),n,t1)
+
+shoePileCtree(x,y)==dqAppend(x,shoePileCforest y)
+
+-- only enshoePiles forests with >=2 trees
+
+shoePileCforest x==
+ if null x
+ then []
+ else if null cdr x
+ then car x
+ else
+ a:=car x
+ b:=shoePileCoagulate(a,rest x)
+ if null cdr b
+ then car b
+ else shoeEnPile shoeSeparatePiles b
+
+shoePileCoagulate(a,b)==
+ if null b
+ then [a]
+ else
+ c:=car b
+ if EQ(shoeTokPart CAAR c,"THEN") or EQ(shoeTokPart CAAR c,"ELSE")
+ then shoePileCoagulate (dqAppend(a,c),cdr b)
+ else
+ d:=CADR a
+ e:=shoeTokPart d
+ if EQCAR(d,"KEY") and
+ (GET(e,"SHOEINF") or EQ(e,"COMMA") or EQ(e,"SEMICOLON"))
+ then shoePileCoagulate(dqAppend(a,c),cdr b)
+ else cons(a,shoePileCoagulate(c,rest b))
+
+shoeSeparatePiles x==
+ if null x
+ then []
+ else if null cdr x
+ then car x
+ else
+ a:=car x
+ semicolon:=dqUnit
+ shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a)
+ dqConcat [a,semicolon,shoeSeparatePiles cdr x]
+
+shoeEnPile x==
+ dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x),
+ x, _
+ dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)]
+
+@
+
+<<pile.clisp>>=
+(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-pile"))
+
+(IMPORT-MODULE "includer")
+
+(IMPORT-MODULE "scanner")
+
+(IN-PACKAGE "BOOTTRAN")
+
+(DEFUN |shoeFirstTokPosn| (|t|)
+ (PROG () (RETURN (|shoeTokPosn| (CAAR |t|)))))
+
+(DEFUN |shoeLastTokPosn| (|t|)
+ (PROG () (RETURN (|shoeTokPosn| (CADR |t|)))))
+
+(DEFUN |shoePileColumn| (|t|)
+ (PROG () (RETURN (CDR (|shoeTokPosn| (CAAR |t|))))))
+
+(DEFUN |shoePileInsert| (|s|)
+ (PROG (|a| |toktype|)
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|) (CONS NIL |s|))
+ (#0='T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
+ (COND
+ ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
+ (CONS (LIST (CAR |s|)) (CDR |s|)))
+ (#0# (SETQ |a| (|shoePileTree| (- 1) |s|))
+ (CONS (LIST (ELT |a| 2)) (ELT |a| 3)))))))))
+
+(DEFUN |shoePileTree| (|n| |s|)
+ (PROG (|hh| |t| |h| |LETTMP#1|)
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND
+ ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
+ (#0# (LIST NIL |n| NIL |s|))))))))
+
+(DEFUN |eqshoePileTree| (|n| |s|)
+ (PROG (|hh| |t| |h| |LETTMP#1|)
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND
+ ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
+ (#0# (LIST NIL |n| NIL |s|))))))))
+
+(DEFUN |shoePileForest| (|n| |s|)
+ (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|)
+ (RETURN
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |hh| (CADR . #0=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #0#))
+ (SETQ |t| (CADDDR . #0#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|))
+ (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ ('T (LIST NIL |s|)))))))
+
+(DEFUN |shoePileForest1| (|n| |s|)
+ (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|)
+ (RETURN
+ (PROGN
+ (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |n1| (CADR . #0=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #0#))
+ (SETQ |t| (CADDDR . #0#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|))
+ (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ ('T (LIST NIL |s|)))))))
+
+(DEFUN |shoePileForests| (|h| |n| |s|)
+ (PROG (|t1| |h1| |LETTMP#1|)
+ (RETURN
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
+ (SETQ |h1| (CAR |LETTMP#1|))
+ (SETQ |t1| (CADR |LETTMP#1|))
+ (COND
+ ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
+ ('T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|)))))))
+
+(DEFUN |shoePileCtree| (|x| |y|)
+ (PROG () (RETURN (|dqAppend| |x| (|shoePileCforest| |y|)))))
+
+(DEFUN |shoePileCforest| (|x|)
+ (PROG (|b| |a|)
+ (RETURN
+ (COND
+ ((NULL |x|) NIL)
+ ((NULL (CDR |x|)) (CAR |x|))
+ (#0='T (SETQ |a| (CAR |x|))
+ (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
+ (COND
+ ((NULL (CDR |b|)) (CAR |b|))
+ (#0# (|shoeEnPile| (|shoeSeparatePiles| |b|)))))))))
+
+(DEFUN |shoePileCoagulate| (|a| |b|)
+ (PROG (|e| |d| |c|)
+ (RETURN
+ (COND
+ ((NULL |b|) (LIST |a|))
+ (#0='T (SETQ |c| (CAR |b|))
+ (COND
+ ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
+ (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
+ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
+ (#0# (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
+ (COND
+ ((AND (EQCAR |d| 'KEY)
+ (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
+ (EQ |e| 'SEMICOLON)))
+ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
+ (#0# (CONS |a| (|shoePileCoagulate| |c| (CDR |b|))))))))))))
+
+(DEFUN |shoeSeparatePiles| (|x|)
+ (PROG (|semicolon| |a|)
+ (RETURN
+ (COND
+ ((NULL |x|) NIL)
+ ((NULL (CDR |x|)) (CAR |x|))
+ ('T (SETQ |a| (CAR |x|))
+ (SETQ |semicolon|
+ (|dqUnit|
+ (|shoeTokConstruct| 'KEY 'BACKSET
+ (|shoeLastTokPosn| |a|))))
+ (|dqConcat|
+ (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))))
+
+(DEFUN |shoeEnPile| (|x|)
+ (PROG ()
+ (RETURN
+ (|dqConcat| (LIST (|dqUnit|
+ (|shoeTokConstruct| 'KEY 'SETTAB
+ (|shoeFirstTokPosn| |x|)))
+ |x|
+ (|dqUnit|
+ (|shoeTokConstruct| 'KEY 'BACKTAB
+ (|shoeLastTokPosn| |x|))))))))
+
+@
+
+\end{document}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 01:42:41 +0000