APL/D Source Code:
────────────────────────────────────────────────────────────────────────────────
max←{ ⍝ Max compiler/interpreter.
stream←{ ⍝ Process input stream.
src rem←''next ⍵ ⍝ next line and remainder.
')'=⊃src:envt←retract ⍺ ⍝ quit returning (shy) envt.
exp←⍺ lambda parse src ⍝ lambda expr tree from source.
(⍺ show exp)∇ rem ⍝ show evaluation of statement.
} ⍝ {env} ← env :: [src]
next←{ ⍝ Next complete expression.
clean←{(∧\⍵≠'/')/⍵}∘{⍵~' ·'} ⍝ blanks and comments removed.
src←clean ⍺ input ⍵ ⍝ clean source line.
0∊src∊chars:⍺ ∇(⎕←'?')⊢1↓⍵ ⍝ bad char: error and retry.
''≡src:⍺ ∇ 1↓⍵ ⍝ blank lines ignored.
acc←⍺,src ⍝ accumulated source.
nxt←clean⊃1↓⍵ ⍝ following line.
~'·'∊acc prompt nxt:acc(1↓⍵) ⍝ complete: srce and remainder.
acc ∇ 1↓⍵ ⍝ accumulate current line.
} ⍝ src [src] ← src :: [src]
input←{ ⍝ Input from buffer or keybd.
×⍴⍵:{⍞←⍵,⊃⌽⎕TC ⋄ ⍵}⊃⍵ ⍝ next item from buffer, else
⍞⊣⍞←⍺ prompt'' ⍝ prompt and input from keybd.
} ⍝ src ← src :: [src]
prompt←{ ⍝ Prompt string.
last next←¯1 1↑¨⍺ ⍵ ⍝ joining characters.
dots←'.'∊last,next ⍝ trailing or leading dots.
more←last∊'([,.' ⍝ more to come.
depth←0⌈-/+/¨⍺∘∊¨'([' '])' ⍝ bracket nesting depth.
dent←0⌈dots+depth-~more ⍝ indentation for depth.
cont←4↑(dots∨×depth)/'·' ⍝ continuation indication.
cont,∊dent⍴⊂4↑'·' ⍝ prompt string.
} ⍝ [char] ← src :: src
retract←{↑((⊃⍵)∊alph)/↓⍉↑⍵} ⍝ Envt without primitive defs.
alph←const'alph' ⍝ definition alphabet.
chars←{ ⍝ Max alphabet:
a←alph ⍝ names a=z,
n←'0123456789' ⍝ numbers 0-9,
s←'.()=[,]:+~' ⍝ syntax.
t←'#→',const'vars' ⍝ type expressions.
f←⊃↓⍉↑const'ptypes' ⍝ primitive functions.
c←⊃↓⍉↑const'cdefs' ⍝ combinator names.
l←'\._∇' ⍝ lambda syntax.
∪a,n,s,t,⍵/f,c,l ⍝ names, nums, sntx, type, xtra.
}1 ⍝ accept extended Max exprs.
⍺←0 4⍴'' ⋄ env←extend↓⍺ ⍝ starting environment.
script←(⍵≡'')↓↓⎕FMT↑⍵ ⍝ script as vector of vectors.
env stream script ⍝ Input streamed from script.
}
────────────────────────────────────────────────────────────────────────────────
parse←{ ⍝ Parse tree from Max source vector.
prep←''∘{ ⍝ Preprocess.
''≡⍵:⍺ ⍝ no source: accumulated tokens.
'\.'≡2↑⍵:⍺ ∇ 2↓⍵ ⍝ \.x → x
'\'=⊃⍵:(⍺,⌽2↑⍵)∇'\',2↓⍵ ⍝ \abc.x → a\b\c\x
'::'≡2↑⍵:(⍺,'⊤')∇ 2↓⍵ ⍝ :: → ⊤
dots←+/∧\⍵='.' ⍝ number of 'where' dots.
×dots:(⍺,-dots)∇ dots↓⍵ ⍝ . .. ... ··· → ¯1 ¯2 ¯3 ···
(⍺,⊃⍵)∇ 1↓⍵ ⍝ accumulate token.
}
post←'-' '-' '' ''∘{ ⍝ Postfix from infix.
st bk ac sk←⍺ ⍝ StaTe BracKet AcCumulator StacK.
os←st='⍵' ⍝ operand state.
''≡⍵:(ac,os↓'?',sk)⍵ ⍝ no source: accumulated tokens.
s ss←split ⍵ ⍝ first and remaining source tokens.
0 1≡os,s∊ops:⍺ ∇'?',⍵ ⍝ missing operand: inject dummy.
s∊ops:s ∇{ ⍝ Infix operator:
'(,'≡bk,⍺:'?' ⍝ no tuples for the nonce.
s←('-,'≡bk,⍺)⊃⍺'⋄' ⍝ cons or statement separator.
∆ac ∆sk←ac s,¨s cut sk ⍝ op slotted into ac-sk stacks.
'∇'bk ∆ac ∆sk ⍺⍺ ⍵ ⍝ new stacks in '∇' state.
}ss
s∊'([':s ∇{ ⍝ Left paren or bracket.
sx rm←'-'⍺'' ''⍺⍺ ⍵ ⍝ sub expression and remainder.
r rr←split rm ⍝ right bracket and remainder.
r≠('(['⍳⍺)⊃')]':'?' ⍝ mismatched brackets: error.
∆ac←ac,sx,os/'@' ⍝ new accumulator.
'⍵'bk ∆ac sk ⍺⍺ rr ⍝ output sub expression.
}ss
s∊'])':{ ⍝ Right bracket or paren.
'∇'=st:'?' ⍝ incomplete expression: error.
')'=⊃ac,s:'?' ⍝ (): error.
']'=⊃ac,s:'⍬'⍵ ⍝ []: null.
')'=s:(ac,sk)⍵ ⍝ sub-expression and remainder.
(∊ac'⍬,',¨','cut sk)⍵ ⍝ 'a,b]' → a,b,⍬
}⍵
∆ac←ac,(rand s),os/'@' ⍝ new accumulator.
'⍵'bk ∆ac sk ∇ ss ⍝ output operand.
}
tree←''∘{ ⍝ Tree from postfix.
0=⍴,⍵:⊃⍺ ⍝ no tokens: accumulated tree.
t tt←split ⍵ ⍝ first and remaining tokens.
~t∊ops:(⍺,t)∇ tt ⍝ not an operator: pass it along.
oo a b←(⊂¯2↓⍺),¯2↑'?',⍺ ⍝ operator:2 operands & remainder.
t∊',:':(oo,⊂app'⊂'a b)∇ tt ⍝ cons becomes applied function.
op←(t∊dots)⊃t'.' ⍝ restore "where" dot.
(oo,⊂op a b)∇ tt ⍝ operator bound with operands.
}
split←{(⊃⍵)(1↓⍵)} ⍝ First and remaining items.
cut←{/∘⍵¨1 0=</ops∘⍳¨⍺ ⍵} ⍝ ⍵ cut at binding strength of ⍺.
app←{↑{'@'⍺ ⍵}⍨/⌽⍵} ⍝ function application.
rand←{⍵∊⎕D:⎕D⍳⍵ ⋄ ⍵} ⍝ operand: '0'··'9' → 0··9
dots←¯1-⍳⍴⎕A ⍝ where dots: .a=··.z= → ¯1··¯26
⍺←'⋄~⊤,→',dots,'=\:@' ⋄ ops←,⍺ ⍝ Default operator set.
tree⊃post prep ⍵~' ·' ⍝ Parse tree from source.
}
────────────────────────────────────────────────────────────────────────────────
const←{ ⍝ Implementation constants.
'alph'≡⍵:'abcdefghijklmnopqrstuvwxyz' ⍝ Object name alphabet.
'vars'≡⍵:'⍺⍵∊⍳⍴∆⌽⊖⍉⍙⍷○⍟⍎⍕⍋⍒⍫⍨⊢¥$£¢%⋄' ⍝ Type variable alphabet.
'cdefs'≡⍵:⌽{ ⍝ Combinator definitions:
⍵,⊂'I' ' x ' ' x '}{ ⍝ I Smullyan: Identity/Idiot
⍵,⊂'K' ' cx ' ' c '}{ ⍝ K Kestrel
⍵,⊂'S' ' fgx ' ' fx(gx) '}{ ⍝ S Starling
⍵,⊂'B' ' fgx ' ' f(gx) '}{ ⍝ B Bluebird
⍵,⊂'C' ' fgx ' ' fxg '}{ ⍝ C Cardinal
⍵,⊂'$' ' cfgx ' ' c(fx)(gx) '}{ ⍝ S' Phoenix
⍵,⊂'¢' ' cfgx ' ' c(fx)g '}{ ⍝ C' -
⍵,⊂'&' ' cfgx ' ' c(f(gx)) '}{ ⍝ B* Becard
⍵,⊂'Y' ' x ' ' x(Yx) '}{ ⍝ Y Sage bird
⍵,⊂'∇' ' x ' ' x(Yx) '}⍬ ⍝ Y (synonym)
'ptypes'≡⍵:⌽{ ⍝ Primitive types:
⍵,⊂'+' ' #→# '}{ ⍝ + succ
⍵,⊂'-' ' #→# '}{ ⍝ - pred
⍵,⊂'!' ' #→⍺→⍺→⍺ '}{ ⍝ ! nil?
⍵,⊂'↑' ' [⍺]→⍺ '}{ ⍝ ↑ head
⍵,⊂'↓' ' [⍺]→[⍺] '}{ ⍝ ↓ tail
⍵,⊂'∘' ' [⍺]→⍵→⍵→⍵ '}{ ⍝ ∘ null?
⍵,⊂'⊂' ' ⍺→[⍺]→[⍺] '}{ ⍝ ⊂ cons (link)
⍵,⊂'?' ' ⍺ '}{ ⍝ ? error
⍵,⊂'⍬' ' [⍺] '}{ ⍝ [] null
⍵,⊂'I' ' ⍺→⍺ '}{ ⍝ I Identitätsfunktion
⍵,⊂'K' ' ⍺→⍵→⍺ '}{ ⍝ K Konstanzfunktion
⍵,⊂'S' ' (⍺→∊→⍵)→(⍺→∊)→⍺→⍵ '}{ ⍝ S VerSchmelzungsfunktion
⍵,⊂'Y' ' (⍺→⍺)→⍺ '}⍬ ⍝ Y "Paradoxical combinator"
'opts'≡⍵:⌽{ ⍝ Curry/Turner optimisations:
⍵,⊂' S(K⍺)(K⍵) ' ' K(⍺⍵) '}{ ⍝ K
⍵,⊂' S(K⍺)I ' ' ⍺ '}{ ⍝
⍵,⊂' S(K⍺)(B⍵∊) ' ' &⍺⍵∊ '}{ ⍝ B*
⍵,⊂' S(K⍺)⍵ ' ' B⍺⍵ '}{ ⍝ B
⍵,⊂' S(B⍺⍵)(K∊) ' ' ¢⍺⍵∊ '}{ ⍝ C'
⍵,⊂' S⍺(K⍵) ' ' C⍺⍵ '}{ ⍝ C
⍵,⊂' S(B⍺⍵)∊ ' ' $⍺⍵∊ '}⍬ ⍝ S'
'temps'≡⍵:⌽{ ⍝ Pattern matching templates:
⍵,⊂'!' '\_.!_⍵? '}{ ⍝ if zero.
⍵,⊂'+' '\_.!_?⍵ '}{ ⍝ if non-zero.
⍵,⊂'-' '⍵(-_) '}{ ⍝ predecessor.
⍵,⊂'∘' '\_.∘_⍵? '}{ ⍝ if null.
⍵,⊂'○' '\_.∘_?⍵ '}{ ⍝ if non-null.
⍵,⊂'↓' '⍵(↑_)(↓_)'}⍬ ⍝ split head and tail.
}
────────────────────────────────────────────────────────────────────────────────
compile←{ ⍝ Combinator expression
comp←{ ⍝ Compile expression.
0=⍴⍴⍵:⍵ ⍝ C[c] → c
'@'=⊃⍵:(⊃⍵),∇¨1↓⍵ ⍝ C[e f] → C[e] C[f]
'\'=⊃⍵:↑abs∘∇/1↓⍵ ⍝ C[\x.e] → Ax[ C[e] ]
} ⍝ @exp ← :: \exp
abs←{ ⍝ Variable abstraction.
app←{'@'⍺ ⍵} ⍝ application node.
0=⍴⍴⍵:⍺{ ⍝ atom:
⍺=⍵:'I' ⍝ Ax[x] → I
'K'app ⍵ ⍝ Ax[c] → Kc
}⍵ ⍝
otab opt↑app⍨/⌽'S',⍺ ∇¨1↓⍵ ⍝ Ax[f g] → O[ S Ax[f] Ax[g] ]
} ⍝ @exp ← :: \exp
opt←{ ⍝ Optimise combinator expression.
0=⍴⍺:⍵ ⍝ no optimisation.
fm to tl←(⊃⍺),⊂(1↓⍺) ⍝ first optimisation and tail.
⍝
dict←↓⍉↑fm{ ⍝ substitution dictionary.
6=⍴⍺,⍵:↑,/⍺ ∇¨⍵ ⍝ both expressions: recur.
⍴⍴⍺:⊂'∘'⍵ ⍝ atomic ⍵: no match.
⍺∊'⍺⍵∊':⊂⍺ ⍵ ⍝ wild card: dictionary entry.
⍺≡⍵:'' ⋄ '∘' ⍝ literal match or mis-match.
}⍵ ⍝
⍝
'∘'∊⊃dict:tl ∇ ⍵ ⍝ not this opt, try next.
dict subs to ⍝ substitute optimisation.
} ⍝
subs←{ ⍝ Substitute from dictionary.
tags vals←⍺ ⍝ split dictionary.
{ ⍝
⍴⍴⍵:'@',∇¨1↓⍵ ⍝ apply: traverse tree,
(tags⍳⍵)⊃vals,⍵ ⍝ name: corresponding value.
}⍵ ⍝
} ⍝
otab←⍺ ⋄ comp ⍵ ⍝ Compile \exp
}
────────────────────────────────────────────────────────────────────────────────
unify←{ ⍝ Unification of type expressions.
⍺≡⍵:⍺ ⍝ Easy if identical.
isvar←{0≡⊃0⍴⊂⍵} ⍝ Type variable test.
case←isvar¨⍺ ⍵ ⍝ any type variables?
1∊case:(case⍳0)⊃⍺ ⍵ ⍺ ⍝ yes: choose the other.
dist←{ ⍝ Distinct type variables.
lv rv←vars¨⍵ ⍝ left and right expr type vars.
0=⍴lv∩rv:⍵ ⍝ already distinct: done.
to←(1+⌈/lv,rv)+⍳⍴rv ⍝ vars above those in left expr.
↑{⍺ ⍵}∘{rv to xlate ⍵}/⍵ ⍝ left followed by relocated right.
} ⍝ tex tex ← :: tex tex
subs←⍬ ⍬∘{ ⍝ Substitution table.
≡/⍵:⍺ ⍝ early out if identical.
1 1≡{⊃⍴⍴⍵}¨⍵:↑∇⍨/⌽(⊂⍺),↓⍉↑⍵ ⍝ both exprs deep: traverse each.
case←isvar¨⍵ ⍝ which are type vars?
case≡0 0:(≡/⍵)⊃'?'⍺ ⍝ neither: must match.
case≡1 1:⍺ merge(</⍵)⌽⍵ ⍝ both: merge into subs table.
⍺ merge(~⊃case)⌽⍵ ⍝ either: merge into subs table.
} ⍝ subs ← subs :: exp exp
merge←{ ⍝ Merge new subs into table.
tag val←⍵ ⍝ name and value.
~tag∊⊃⍺:⍺,∘⊂¨⍵ ⍝ new name: append subs.
(⊂val)∊⊃⍺:⍺ ⍝ avoid cycle.
cval←⍺ dref tag ⍝ current value.
val≡cval:⍺ ⍝ early out if no change.
↑∇⍨/⌽(⊂⍺),↓⍉↑subs val cval ⍝ extended subs table.
} ⍝ subs ← subs :: sub
fix←{ ⍝ Fixpoint of function ⍺⍺.
1∊∊{⍺∊∊⍵}¨/⍵:'?' ⍝ cycle: error.
⍵≡z←⍺⍺ ⍵:⍵ ⍝ arg ≡ rslt: done.
∇ z ⍝ arg ≢ rslt: refine.
}
refs←{↑⍵{⍺{⍺ ⍵}⍺⍺ xlate ⍵}/⍵} ⍝ Resolve refs to refs.
xlate←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍺ dref ⍵} ⍝ Scalar-wise translation.
dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⊂⍺⍺}/⍺} ⍝ Dereference from table.
echk←{'?'∊∊⍵:'?' ⋄ ⍵} ⍝ Error pervades expression.
vars←{∪(∊⍵)~⎕AV} ⍝ Type variables used in expr.
stab←refs fix subs dist ⍺ ⍵ ⍝ substitution table.
echk stab xlate ⍺ ⍝ left expr xlated from subs table.
}
────────────────────────────────────────────────────────────────────────────────
defn←{ ⍝ Extend environment.
merge←{ ⍝ Merge current and new \defns.
⍺≡⍵:⍺ ⍝ identical: done.
1 1≡{⊃⍴⍴⍵}¨⍺ ⍵:⍺ ∇¨⍵ ⍝ both compound: examine each.
(⍺ ⍵⍳'?')⊃⍵ ⍺ ⍺ ⍝ one unknown: use the other.
}
link←{ ⍝ Bind external refs from envt ⍺.
⍴⍴⍵:(⊃⍵),∇¨1↓⍵ ⍝ traverse expression scalar-wise.
~⍵∊alph:⍵ ⍝ not a name: preserve.
(tags⍳⍵)⊃cdefs,⍵ ⍝ replaced with value from envt.
}
free←{ ⍝ Var ⍺ free in exp ⍵?
0=⍴⍴⍵:⍺=⍵ ⍝ atom: free if same as var.
'\'⍺≡2↑⍵:0 ⍝ var bound here: not free.
∨/⍺ ∇¨1↓⍵ ⍝ not \abs, free in either sub?
} ⍝ bool ← var :: exp.
alph←const'alph' ⍝ Name alphabet.
yfree←{⍺ free ⍵:⍺ bindy ⍵ ⋄ ⍵} ⍝ Bind free var with lambda.
bindy←{'@' 'Y'('\'⍺ ⍵)} ⍝ Bind var with lambda.
tags ldefs cdefs tdefs←⍺ ⍝ Environment.
_ tag lex←⍵ ⍝ name and value.
~tag∊alph:⍺⊣⎕←'?' ⍝ bad name: retain current envt.
odef←(tags⍳tag)⊃ldefs,⊂lex ⍝ current \defn.
ldef←lex merge odef ⍝ merged old and new \defns.
otab←(tags⍳'○')⊃cdefs ⍝ compilation optimisation table.
cdef←otab compile tag yfree ldef ⍝ combinator definition.
told←(tags⍳tag)⊃tdefs,0 ⍝ existing type defn.
tdef←told unify ⍺ type cdef ⍝ new type defn.
'?'∊∊tdef:⍺⊣⎕←'?' ⍝ error: retain existing envt.
cabs←link cdef ⍝ bind external refs @ defn time.
dnew←tag ldef cabs tdef ⍝ complete new definition.
dnew{(⊂⍺),⍵}¨(tag≠tags)∘/¨⍺ ⍝ merged into environment.
}
────────────────────────────────────────────────────────────────────────────────
extend←{ ⍝ Extend supplied environment.
ctypes←{ ⍝ deduce combinator types.
name args dsrc←⍵ ⍝ template, definition source.
cdef←parse dsrc ⍝ combinator definition.
temp←args~' ' ⍝ argument template.
lexp←↑{'\'⍺ ⍵}/temp,⊂cdef ⍝ lambda definition.
mask←(⊃¨⍺)∘{∧/⍵∊⍺}¨orefs ⍝ mask for safe optimisations.
cexp←(mask/opts)compile lexp ⍝ combinator expression.
tdef←(↓⍉↑⍺)type cexp ⍝ type definition.
renv←(name≠⊃¨⍺)/⍺ ⍝ remaining environment.
renv,⊂name temp cdef tdef ⍝ environment tuple.
} ⍝ env ← [src] :: env
func←{ ⍝ function table entry.
name texp←table ⍵ ⍝ name, args and type source.
temp←(+/'→'=∊texp)⍴'⍵' ⍝ argument template.
1 1 0 1\name temp texp ⍝ function table entry.
} ⍝ def ← :: [src]
patn←{{parse ⍵}\⍵} ⍝ pattern matching template.
numb←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍵∊⍺:⍺⍳⍵ ⋄ ⍵} ⍝ conv ⍺, ⍵, ∊, ··· → 0, 1, 2,
table←{↑{⍺,⊂vars numb parse ⍵}/⍵} ⍝ tag with parsed expression.
vars←const'vars' ⍝ type variables.
cdefs←const'cdefs' ⍝ combinator definitions.
ptypes←const'ptypes' ⍝ primitive types.
ctags ptags←⊃¨¨cdefs ptypes ⍝ combinator and function names.
opts←'@'parse¨¨const'opts' ⍝ combinator optimisations.
orefs←(⊃¨cdefs)∘{⍺∩∊⍵}¨opts ⍝ optimisation combinator refs.
temps←↓⍉↑patn¨const'temps' ⍝ pattern matching templates.
boot←{1 0 0 1\table ⍵} ⍝ combinator type bootstrap.
btab←boot¨(ptags∊ctags)/ptypes ⍝ bootstrap with primitive types.
ctab←↑ctypes⍨/(⌽cdefs),⊂btab ⍝ primitive combinator table.
ftab←func¨(~ptags∊ctags)/ptypes ⍝ primitive function table.
otab←⊂1 0 1 0\'○'opts ⍝ optimisation table.
ptab←⊂1 1 0 0\'≡'temps ⍝ pattern matching templates.
↓⍉↑ftab,ctab,otab,ptab,⍵ ⍝ complete environment.
}
────────────────────────────────────────────────────────────────────────────────
equn←{ ⍝ Lambda from equation.
lexpr←{ ⍝ Lambda expression from equation.
0=⍴⍴⍺:⍺(env lambda ⍵) ⍝ simple: finished.
_ hd tl←⍺ ⍝ head and tail of fun-arg list.
hd ∇ tl larg ⍵ ⍝ traverse subtree to left of '='.
}
larg←{ ⍝ Lambda expr from argt pattern.
'@'=⊃⍺:⍺ apply ⍵ ⍝ number successor: (+i), (+(+i)),
0=⊃0⍴⍺:⍺ digit ⍵ ⍝ numeric literal: 0, 1,
'⍬'=⍺:null ⍵ ⍝ null list: [],
'\'⍺ ⍵ ⍝ simple name: i, j,
}
apply←{ ⍝ Apply arg.
_ fun arg←⍺ ⍝ fun and arg.
'+'≡fun:numb pred arg larg ⍵ ⍝ + succ
'@⊂'≢2↑fun:'?' ⍝ not cons: error
hd←2⊃fun ⋄ tl←arg ⍝ head and tail.
list cons hd larg tl larg ⍵ ⍝ list.
}
digit←{ ⍝ Numeric arg.
⍺=0:zero ⍵ ⍝ f 0: ···
numb pred(⍺-1)∇ ⍵ ⍝ f n:
}
subs←{ ⍝ Substitute ⍵ for '⍵' in ⍺.
⍴⍴⍺:⍺ ∇¨⊂⍵ ⍝ traverse ⍺,
⍺='⍵':⍵ ⋄ ⍺ ⍝ subs '⍵' for ⍵.
}
dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⊂⍺⍺}/⍺} ⍝ dereference from table.
env←⍺ ⋄ temp←(2↑env)dref'≡' ⍝ pattern matching templates.
zero←(temp dref'!')∘subs ⍝ template for zero test.
numb←(temp dref'+')∘subs ⍝ .. .. .. non-zero test.
pred←(temp dref'-')∘subs ⍝ .. .. .. predecessor.
null←(temp dref'∘')∘subs ⍝ template for null test.
list←(temp dref'○')∘subs ⍝ .. .. .. non-null test.
cons←(temp dref'↓')∘subs ⍝ .. .. .. list constructor.
'=',↑lexpr/1↓⍵ ⍝ f i j k = ⍵ → f = \ijk.⍵
}
────────────────────────────────────────────────────────────────────────────────
lambda←{ ⍝ Lambda expression from parse tree.
0=⍴⍴⍵:⍵ ⍝ atom: done.
op lft rgt←⍵ ⍝ split expression.
'='=op:⍺ equn ⍵ ⍝ equation:
'.'=op:⍺ local ⍵ ⍝ local definition:
op,⍺∘∇¨lft rgt ⍝ process subtrees.
}
────────────────────────────────────────────────────────────────────────────────
local←{ ⍝ Lambda from 'where' clause(s).
lexp←{ ⍝ encapsulate local definitions.
'='≢⊃⍵:'?' ⍝ not both equations: error.
'='≢⊃⍺:2⊃('=_',⊂⍺)∇ ⍵ ⍝ complete primary definition.
_ ltag lval←⍺ ⍝ left equation.
_ rtag rval←⍵ ⍝ right equation.
{'='ltag ⍵}rtag{ ⍝
0=⍴⍴⍵:(⍺≡⍵)⊃⍵ rval ⍝ atom:
case←⍺ free¨1↓⍵ ⍝ name free in subtrees.
0 0≡case:⍵ ⍝ neither: omit local defn.
1 1≡case:'@'('\'⍺ ⍵)rval ⍝ both: insert lambda abs here.
op lft rgt←⍵ ⍝ split expr.
0 1≡case:op lft(⍺ ∇ rgt) ⍝ pursue right subtree.
1 0≡case:op(⍺ ∇ lft)rgt ⍝ pursue left subtree
}lval ⍝ local definition body.
} ⍝ exp ← exp :: exp
merge←{ ⍝ Merge current and new \defns.
(2↑⍺)≢2↑⊃⍵:(⊂⍺),⍵ ⍝ distinct equation: continue.
mrg←{ ⍝ new merged equation.
1 1≡{⊃⍴⍴⍵}¨⍺ ⍵:⍺ ∇¨⍵ ⍝ both compound: examine each.
(⍺ ⍵⍳'?')⊃⍵ ⍺ ⍺ ⍝ one unknown: use the other.
} ⍝ merged with previous equation.
(⊂⍺ mrg⊃⍵),1↓⍵ ⍝ new head of equations.
} ⍝ [exp] ← exp :: [exp]
trav←{ ⍝ Traverse where clauses.
op lft rgt←⍵ ⍝
lexp←⊂⍺ lambda lft ⍝
op≡⊃rgt:lexp,⍺ ∇ rgt ⍝
lexp,⊂⍺ lambda rgt ⍝
} ⍝ [exp] ← op :: exp
yify←{ ⍝ Use Y combinator for recursion.
eq tag val←⍵ ⍝ name and equation body.
~tag free val:⍵ ⍝ name not free in body: done.
abs←'\'tag val ⍝ lambda abstraction.
app←'@' 'Y'abs ⍝ applied Y combinator.
eq tag app ⍝ new equation.
} ⍝ exp ← :: exp
free←{ ⍝ Var ⍺ free in exp ⍵?
0=⍴⍴⍵:⍺≡⍵ ⍝ atom: free if it's the var.
'\'⍺≡2↑⍵:0 ⍝ var bound here: not free.
∨/⍺ ∇¨1↓⍵ ⍝ not \abs, free in either sub?
} ⍝ bool ← var :: exp.
defs←¯1↓↑merge/(⍺ trav ⍵),'?' ⍝ local definitions.
↑lexp⍨/⌽(1↑defs),yify¨1↓defs ⍝ complete definition.
}
────────────────────────────────────────────────────────────────────────────────
type←{ ⍝ Type of expression.
infer←{ ⍝ Expression type inference.
0=⍴⍴⍵:⍺{ ⍝ atom:
0=⊃0⍴⍵:'#' ⍝ number: type num.
~⍵∊⊃env:'?' ⍝ unbound name: error.
⍺ bias env dref ⍵ ⍝ type from environment.
}⍵ ⍝ name or literal.
_ fun arg←⍵ ⍝ apply node: function and argument.
op fm to←⍺ ∇ fun ⍝ function component types.
op≢'→':'?' ⍝ non-function
base←⍺ next fm to ⍝ variable base.
targ←base ∇ arg ⍝ right subtree.
⊃⌽fm to unify targ 0 ⍝ unified result type.
} ⍝ tex ← nxt :: exp
bias←{(⍺ btab ⍵)xlate ⍵} ⍝ Bias type vars above ⍺.
btab←{⍺{⍵(⍺+⍳⍴⍵)}vars ⍵} ⍝ bias table
xlate←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍺ dref ⍵} ⍝ Scalar-wise translation.
dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⍺⍺}/⍺} ⍝ Dereference from table.
next←{1+⌈/⍺,vars ⍵} ⍝ Next avail type variable.
vars←{∪(∊⍵)~⎕AV} ⍝ Type variables used in expr.
env←1 0 0 1/⍺ ⍝ type definitions.
0 bias 1 infer ⍵ ⍝ normalised inferred type.
}
────────────────────────────────────────────────────────────────────────────────
typex←{ ⍝ Type expression.
query←{ ⍝ query environment.
otab←(tags⍳'○')⊃cdefs ⍝ compile optimisation table.
obj←otab compile exp ⍝ object code.
tex←env type obj ⍝ expression type.
tex≡obj:env(rem put'?') ⍝ error: error.
env(rem put tfmt tex) ⍝ display type, return envt.
} ⍝ env rem ← :: exp
tfmt←{ ⍝ Type expr format.
0=⍴⍴⍵:{ ⍝ Atom:
0=⊃0⍴⍵:⍵⊃vars ⍝ type variable.
('⍬'=⍵)⊃⍵'[]' ⍝ null or constructor.
}⍵ ⍝ formatted atom.
'→'=⊃⍵:∇{ ⍝ Function type:
argt rslt←⍺⍺¨⍵ ⍝ arg and rslt types.
lp rp←('→'=⊃⊃⍵)/¨'()' ⍝ parens.
lp,argt,rp,'→',rslt ⍝ parenthesised expr.
}1↓⍵ ⍝ function and argument.
'@'=⊃⍵:∇{ ⍝ Cons application type.
func argt←⍺⍺¨⍵ ⍝ head and tail.
func≡'⊂':'[',argt ⍝ leftmost application.
func,1↓argt ⍝ ···:[] → ···]
}1↓⍵ ⍝ function and argument.
} ⍝ tex ← :: exp
spec←{ ⍝ Type specification.
_ tag tex←⍵ ⍝ name and type expression.
renv←(tags≠tag)∘/¨env ⍝ remaining environment.
told←(tags⍳tag)⊃tdefs,0 ⍝ old type definition.
tnew←told unify tex ⍝ new refined type definition.
'?'∊∊tnew:env(1 put'?') ⍝ error: error.
lnew←(tags⍳tag)⊃ldefs,'?' ⍝ lambda defn or wild card.
cnew←(tags⍳tag)⊃cdefs,'?' ⍝ combinator defn or wild card.
defn←tag lnew cnew tnew ⍝ new definition.
xenv←renv,∘⊂¨defn ⍝ extended environment.
xenv rem ⍝ new envt and remaining cols.
} ⍝ env rem ← :: def
put←{rem←⍺⌊⍴,⍵ ⋄ ⍞←rem↑⍵ ⋄ ⍺-rem} ⍝ Put string to session.
env rem←⍺ ⍝ envt and remaining cols.
tags ldefs cdefs tdefs←env ⍝ environment.
op exp tex←⍵ ⍝ ⊤, exp, type-def.
vars←const'vars' ⍝ type variables.
tex≡'?':query exp ⍝ type query.
~(⊂exp)∊const'alph':env(1 put'?') ⍝ type spec of non-name: error.
numb←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍵∊⍺:⍺⍳⍵ ⋄ ⍵} ⍝ conv ⍺, ⍵, ∊, ··· → 0, 1, 2,
spec vars numb ⍵ ⍝ type specification.
}
────────────────────────────────────────────────────────────────────────────────
reduce←{ ⍝ Combinator reduction.
eval←{ ⍝ Value of @exp.
⍴⍴⍵:(∇ 1⊃⍵)apply 2⊃⍵ ⍝ function application.
~⍵∊tags:⍵ ⍝ number, null or error.
⍵'',(tags⍳⍵)⊃defs ⍝ function suspension.
} ⍝ exp ← :: exp
apply←{ ⍝ Function application.
'?'≡⍺:'?' ⍝ bad function: error.
0=⍴⍴⍺:(eval ⍺)∇ ⍵ ⍝ evaluate primitive function.
tag rgs tmp def←⍺ ⍝ name, args, template, defn.
args←rgs,⊂⍵ ⍝ extended args vector.
(⍴args)<⍴tmp:tag args tmp def ⍝ too few args: suspension.
tag∊'+-!':tag numb args ⍝ primitive numeric function.
tag∊'⊂↑↓∘':tag list args ⍝ primitive list function.
eval{ ⍝ combinator:
⍴⍴⍵:'@',∇¨1↓⍵ ⍝ traverse definition,
(tmp⍳⍵)⊃args,⍵ ⍝ substituting values.
}def ⍝ combinator definition.
} ⍝ exp ← exp :: exp
numb←{ ⍝ Number primitive function.
n←whnf⊃⍵ ⍝ strictly numeric first arg.
'?'=n:'?' ⍝ error: error.
'+'=⍺:n+1 ⍝ + succ
'-'=⍺:n-1 ⍝ - pred
eval(1+×n)⊃⍵ ⍝ ! nil?
} ⍝ exp ← op :: exp
list←{ ⍝ List primitive function.
h←whnf⊃⍵ ⍝ first arg to weak head.
'?'≡h:'?' ⍝ error: error.
'⊂'=⍺:↑{'@'⍺ ⍵}⍨/⌽⍺ h,1↓⍵ ⍝ ⊂ cons
'↑'=⍺:{⍵≡'⍬':'?' ⋄ 1 2⊃⍵}h ⍝ ↑ head
'↓'=⍺:{⍵≡'⍬':'?' ⋄ 2⊃⍵}h ⍝ ↓ tail
eval(2-h≡'⍬')⊃⍵ ⍝ ∘ null?
} ⍝ exp ← op :: exp
whnf←{ ⍝ Weak Head Normal Form.
0=⍴⍴⍵:⍵ ⍝ atom: done.
4=⍴⍵:↑{'@'⍺ ⍵}⍨/⌽↑,/2↑⍵ ⍝ function suspension.
'@⊂'≡2↑1⊃⍵:⍵ ⍝ list construction: done.
∇ eval ⍵ ⍝ re-evaluate.
} ⍝ exp ← :: exp
tags defs←{ ⍝ Combinator definition table.
tags temp cdefs tdefs←⍵ ⍝ environment.
mask←~tags∊'⍬?' ⍝ ignoring null and error.
mask∘/¨tags(↓⍉↑temp cdefs) ⍝ definition table for eval.
}⍺ ⍝ environment.
whnf ⍵ ⍝ Reduce to whnf.
}
────────────────────────────────────────────────────────────────────────────────
show←{ ⍝ Display output from statement.
stmt←{ ⍝ evaluate each ⋄ segment.
env rem←⍺ ⍝ envt and remaining cols.
'⋄'=⊃⍵:⍺ segs ⍵ ⍝ separator: evaluate left to right.
'⊤'=⊃⍵:⍺ typex ⍵ ⍝ type: display or set type.
'='=⊃⍵:(env defn ⍵)rem ⍝ definition: extend environment.
'~'=⊃⍵:⍺ remove ⍵ ⍝ remove: compress environment.
obj←(env dref'○')compile ⍵ ⍝ object code.
'?'≡env type obj:⍺ put'?' ⍝ type error: error.
⍺ expr env reduce env link obj ⍝ show reduced expr.
} ⍝ env rem ← env rem :: exp
segs←{ ⍝ Eval left and right ⋄ segments.
lft←⍺ stmt 1⊃⍵ ⍝ envt and cols after left segt.
sepr←(≢/1⊃¨⍺ lft)/', ' ⍝ separator if output from left.
(lft put sepr)stmt 2⊃⍵ ⍝ envt and cols after right segt.
} ⍝ env rem ← env rem :: exp
expr←{ ⍝ Session-wide display.
0=⍴⍴⍵:⍺ put('⍬'=⍵)⊃⌽'[]'(⍕⍵) ⍝ Atom.
_ fn arg←⍵ ⍝ function and argument.
'@⊂'≡2↑fn:(⍺ put'[')list ⍵ ⍝ list.
fun←⍺ ∇ fn ⍝ envt and cols after function.
0=⍴⍴arg:fun ∇ arg ⍝ atomic argument: no parentheses.
((fun put'(')∇ arg)put')' ⍝ show argument in parentheses.
} ⍝ env rem ← env rem :: exp
list←{ ⍝ list items.
env rem←⍺ ⍝ envt and remaining cols.
rem=0:⍺ ⍝ run off edge of session: quit.
⍵≡'?':⍺ put'?' ⍝ error: error.
head←⍺ expr env reduce 1 2⊃⍵ ⍝ envt and cols after head.
tlex←env reduce 2⊃⍵ ⍝ tail expression.
tlex≡'⍬':head put']' ⍝ tail null: end of list.
(head put',')∇ tlex ⍝ envt and cols after tail.
} ⍝ env rem ← env rem :: exp
remove←{ ⍝ Removal/retention of names.
env rem←⍺ ⍝ envt and remaining cols.
keep←(⊃env){ ⍝ names to retain.
'~'=⊃⍵:⍺~alph∩⍺ ∇ 2⊃⍵ ⍝ remv: exclude name.
'@'=⊃⍵:∊⍺∘∇¨1↓⍵ ⍝ accumulate names.
(⍴⍴⍵)↓⊂⍵ ⍝ atom: name or null.
}⍵ ⍝ [char] ← [char] :: exp
renv←((⊃env)∊keep)∘/¨env ⍝ reduced environment.
renv rem put∊2↑¨⌽keep∩alph ⍝ show remaining definitions.
} ⍝ env rem ← env rem :: rex
link←{ ⍝ Bind external refs from envt.
⍴⍴⍵:(⊃⍵),⍺∘∇¨1↓⍵ ⍝ scalar-wise:
~⍵∊alph:⍵ ⍝ not a name: preserve.
⍺ dref ⍵ ⍝ replaced with value from envt.
} ⍝ exp ← env :: exp
put←{env rem←⍺ ⋄ env(rem sput ⍵)} ⍝ Envt and remainder after put.
sput←{rem←⍺⌊⍴,⍵ ⋄ ⍞←rem↑⍵ ⋄ ⍺-rem} ⍝ Put string to session.
dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,'?'}/1 0 1 0/⍺} ⍝ Dereference from table.
alph←const'alph' ⍝ definition alphabet.
maxw←⎕PW-1 ⍝ maximum output width
env rem←⍺ maxw stmt ⍵ ⍝ new env and remaining cols.
⊃env 1 put(rem<maxw)/⊃⌽⎕TC ⍝ newline after any output.
}
────────────────────────────────────────────────────────────────────────────────
trees←{ ⍝ Format [char;] ← :: exp
0=≡⍵:⍕⍵ ⍝ lonely leaf.
⍺←'┌─┐' ⋄ ll mm rr←⍺ ⍝ default line drawing chars.
(0≡⊃0⍴⍵)∨(0≠≡⊃⍵)∨(,3)≢⍴⍵:⍺∘∇¨⍵ ⍝ not a tree: perhaps a spinney?
1 0↓' '{ ⍝ dummy header for top node.
0=≡⍵:↑(⊃1↓⍺)(,⍕⍵) ⍝ atom - done.
subs←(' 'll mm)(mm rr' ')∇¨1↓⍵ ⍝ formatted sub trees.
r c←↑⌈/⍴¨subs ⍝ rows and cols.
fill←r↑⊃⍵ ⍝ filler between subs.
mr←{(⍺⍺⌽⊃⍵)(⍺⍺⊃⌽⍵)} ⍝ mirror operator.
xsbs←⊢mr{r c↑⍵}mr subs ⍝ expanded sub trees.
gap←{+/∧\⍵∊' ',mm}mr xsbs ⍝ extra space between subtrees.
cut←⌊/↑+/gap ⍝ number of cols to cut.
rc←cut+lc←-cut⌊⊃gap ⍝ left cut and right cut.
lt rt←lc rc{⍺↓¨↓⍵}¨xsbs ⍝ inside extra cols removed.
this←{(∨⌿⍵≠' ')/⍵}↑lt,¨fill,¨rt ⍝ outside blank cols removed.
mask←(⊃⍵)≠⊃↓this ⍝ left and right spacing.
repl←{+/∧\⍵}¨(mask)1(⌽mask) ⍝ replication for header.
(repl/⍺)⍪this ⍝ formatted tree and header.
}⍵
}
────────────────────────────────────────────────────────────────────────────────
Back to: contents