;
sheltas.she v1999.12.23 (c)2000 Chris Pressey, Cat's Eye Technologies.
A bootstrappable Shelta compiler written in Shelta/GUPI.
;
[ __0 ]=safestart
[ __0 ]=namestart
[ __0 ]=codeba
[ __0 ]=stacba
[ __0 ]=safeba
[ __0 ]=macrba
[ __0 ]=tokenba
[ __0 ]=symthead
[ __0 ]=codeh
[ __0 ]=stach
[ __0 ]=safeh
[ __0 ]=macrh
[ __0 ]=tokenh
[ begin \16 halt end ]=badtok
[ begin dupz end ]=fndupz
;--------------------------------------;
[ __0 ]=newn
[ ; addr dlen strz -> void ;
begin
^fndupz do
; link up the new node ;
^symthead getw \6 ll-node dup ^newn putw ll-link
^newn getw ^symthead putw
; addr dlen strz ;
^newn getw ll-dptr putw
^newn getw ll-dptr \2 + putw
^newn getw ll-dptr \4 + putw
end
]=InsertSymbol
[ __0 ]=lui
[ __0 ]=luitok
[ \0 end ]=luno
[ ^lui getw ll-dptr \4 + getw
^lui getw ll-dptr \2 + getw end ]=luyes
[ ; strz -> dlen addr, that is, addr is pushed first;
begin
^luitok putw
^symthead getw ^lui putw
[ ]=luloop
^lui getw zero ^luno toif
^lui getw ll-dptr getw ^luitok getw eqzz ^luyes toif
^lui getw ll-next ^lui putw
^luloop to
]=LookupSymbol
;--------------------------------------;
[ __0 ]=ddtoken ; contains pointer into token where to decipher ;
[ __0 ]=ddvalue ; contains running tally of the value ;
[
begin
^tokenba getw + ^ddtoken putw
\0 ^ddvalue putw
[ ]=ddLoop
^ddvalue getw \10 *
^ddtoken getw getb \48 - +
^ddvalue putw
^ddtoken @++
^ddtoken getw getb \47 > ^ddLoop toif
^ddvalue getw
end
]=DecipherDecimal
;--------------------------------------;
[
begin
^codeh getw ++ putw
\184 ^codeh getw putb
\80 ^codeh getw \3 + putb
^codeh getw \4 + ^codeh putw
end
]=WritePush
[
begin
\1 ^DecipherDecimal do ^WritePush do
end
]=PushWord
;--------------------------------------;
[
^tokenba getw \2 + ^LookupSymbol do pop
dup zero ^badtok toif
^safeba getw - \260 +
^codeh getw putw
^codeh getw \2 + ^codeh putw
end
]=LiteralSymbol
[
\2 ^DecipherDecimal do ^codeh getw putw
^codeh getw \2 + ^codeh putw
end
]=LiteralWord
[
begin
^tokenba getw ++ getb \95 - zero ^LiteralWord toif
^tokenba getw ++ getb \94 - zero ^LiteralSymbol toif
\1 ^DecipherDecimal do
^codeh getw putb
^codeh @++
end
]=LiteralByte
;--------------------------------------;
[
begin
^tokenba getw ++ ^LookupSymbol do pop
dup zero ^badtok toif
^safeba getw - \260 + ^WritePush do
end
]=PushPointer
;--------------------------------------;
[ __0 ]=strct
[
begin
\1 ^strct putw
[ ]=strLoop
^tokenba getw ^strct getw + getb
^codeh getw putb
^codeh @++
^strct @++
^tokenba getw ^strct getw + getb ^strLoop toif
end
]=String
;--------------------------------------;
[
begin
^codeh getw
^stach getw putw
^stach getw \2 + ^stach putw
end
]=BeginBlock
[ __0 ]=ebtokptr
[ __0 ]=ebtoklen
[ __0 ]=ebdatlen
[ __0 ]=origcodeh
[
begin
; adjust namestart ... possibly the weirdest Shelta-ism ;
^namestart getw ^origcodeh getw + ^stach getw \2 - getw - ^namestart putw
end
]=AdjustName
[ __0 ]=nei ; a shared counter the for next two subroutines ;
[
^macrh getw ^namestart putw
; copy everything from origcodeh to codeh into the macro area ;
^origcodeh getw ^nei putw
[ ]=mloop
^nei getw getb ^macrh getw putb
^nei @++
^macrh @++
^nei getw ^codeh getw - ^mloop toif
; change codeh back to origcodeh ;
^origcodeh getw ^codeh putw
end
]=MacroInstead
[
begin
^tokenba getw ++ getb \58 - zero ^MacroInstead toif
; copy everything from origcodeh to codeh into a safe area ;
^origcodeh getw ^nei putw
[ ]=neloop
^nei getw getb ^safeh getw putb
^nei @++
^safeh @++
^nei getw ^codeh getw - ^neloop toif
; change codeh back to origcodeh ;
^origcodeh getw ^codeh putw
end
]=NotEmpty
[ begin ^tokenba getw \2 + ^ebtokptr putw end ]=incebtokptr
[
; insert name into dictionary ;
^namestart getw ^ebdatlen getw ^ebtokptr getw ^InsertSymbol do
end
]=NameIt
[
begin
^tokenba getw ++ ^ebtokptr putw
^tokenba getw ++ getb \58 - zero ^incebtokptr doif
^tokenba getw ++ getb \61 - zero ^incebtokptr doif
^safeh getw dup ^safestart putw ^namestart putw ; track starts ;
^ebtokptr getw lenz ^ebtoklen putw
^stach getw \2 - ^stach putw
^stach getw getw ^origcodeh putw ; get original code head ;
^codeh getw ^origcodeh getw - ^ebdatlen putw
^stach getw ^stacba getw - ^AdjustName doif
^ebdatlen getw \0 > ^NotEmpty doif
; write push instruction if '=' or ':' not used ;
^tokenba getw ++ getb \58 - zero ^NameIt toif
^tokenba getw ++ getb \61 - zero ^NameIt toif
\184 ^codeh getw putb
\80 ^codeh getw \3 + putb
^safestart getw ^safeba getw \260 - - ^codeh getw ++ putw
^codeh getw \4 + ^codeh putw
^tokenba getw ++ getb ^NameIt toif
end
]=EndBlock
;--------------------------------------;
[ __0 ]=urctr
[ __0 ]=urlen
[ __0 ]=uraddr
[
^codeh getw -- -- ^codeh putw
; ^codeh \4 \2 fwrite ^crlf \2 \2 fwrite ;
end
]=wipeit
[
^codeh getw \2 - getb \80 - zero ^wipeit toif end
]=peep
[
^codeh getw -- getb \88 - zero ^peep toif end
]=peepok
[
begin
^codeh getw ^codeba getw - ^peepok toif end
]=clean
[
[ ]=urloop
^uraddr getw getb ^codeh getw putb
^uraddr @++
^codeh @++
^urlen @--
^urctr @++
^urctr getw -- zero ^clean doif
^urlen getw ^urloop toif
end
]=curloop
[
begin
\0 ^urctr putw ^tokenba getw ^LookupSymbol do ^urlen putw
dup zero ^badtok toif
^uraddr putw
; copy urlen bytes from uraddr to codeh ;
; 1999.10.14 peephole optimization commented out.
it crashes and it's not strictly necessary. someday, perhaps... ;
^urlen getw ^curloop toif
end
]=Unroll
;--------------------------------------;
[ end ]=goodc ; char was dupped and is on stack ;
[
begin
[ ]=floop
qinc dup \59 - ^goodc toif pop ; return good char if not semicolon ;
[ ]=cloop
qinc \59 - zero ^floop toif
^cloop to
end
]=scanc
[ _0 ]=inbyte
[ _0 ]=eoff
[ \1 ^eoff putb end ]=goteof
[
begin
^tokenba getw ^tokenh putw
[ ]=scanloop
^scanc do ^inbyte putb
^inbyte getb \11 - zero ^goteof toif
\33 ^inbyte getb > ^scanloop toif
[ ]=scisloop
^inbyte getb ^tokenh getw putb ^tokenh @++ ;write char to token;
^scanc do ^inbyte putb
^inbyte getb zero ^goteof toif
^inbyte getb \32 > ^scisloop toif
\0 ^tokenh getw putb
end
]=scantok
; --- startup --- get dynamic memory off of heap --- ;
\16384 malloc dup ^safeba putw \2 + ^safeh putw
\4096 malloc dup ^macrba putw ^macrh putw
\4096 malloc dup ^codeba putw ^codeh putw
\256 malloc dup ^stacba putw ^stach putw
\128 malloc dup ^tokenba putw ^tokenh putw
[
; write output file ;
; put in a jump over the safe area ;
^safeh getw ^safeba getw - ++
\233 outc
dup \255 & outc \8 >> \255 & outc
\144 outc
; make the first word of the safe area an offset ;
; to just past the last word of the code ;
^safeh getw ^safeba getw - ^codeh getw + ^codeba getw \260 - - ^safeba getw putw
^safeba getw ^safeh getw ^safeba getw - outs
^codeba getw ^codeh getw ^codeba getw - outs
\0 halt
]=tail
[ [ ]=main
^scantok do
^eoff getb ^tail toif
^tokenba getw getb \91 - \5 > ^Unroll doif
^tokenba getw getb \91 - zero ^BeginBlock doif
^tokenba getw getb \92 - zero ^PushWord doif
^tokenba getw getb \93 - zero ^EndBlock doif
^tokenba getw getb \94 - zero ^PushPointer doif
^tokenba getw getb \95 - zero ^LiteralByte doif
^tokenba getw getb \96 - zero ^String doif
^main to
]=Shelta ^Shelta to
; end of sheltas.she ;