From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/boot/pile.boot.pamphlet | 325 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 325 insertions(+) create mode 100644 src/boot/pile.boot.pamphlet (limited to 'src/boot/pile.boot.pamphlet') 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} + +<>= +-- 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. + +@ +<<*>>= +<> + +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)] + +@ + +<>= +(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} -- cgit v1.2.3