├── .gitignore ├── APL_PARSE.sig ├── AplAst.sml ├── AplLex.sml ├── AplParse.sml ├── MIT_LICENSE.md ├── Makefile ├── PARSE_COMB.sig ├── ParseComb.sml ├── README.md ├── REGION.sig ├── Region.sml ├── aplparse.mlb ├── aplparse.smackspec ├── test.mlb ├── test.sml └── tests ├── boolean.apl ├── chars.apl ├── circ.apl ├── complex.apl ├── float.apl ├── idx.apl ├── idx2.apl ├── math.apl ├── mult.apl ├── prelude.apl ├── primes.apl ├── quadassign.apl ├── quadids.apl ├── sierpinski.apl ├── test.apl ├── test1.apl ├── test2.apl ├── test3.apl ├── test4.apl ├── test5.apl ├── thorn.apl ├── train.apl ├── trainatop.apl ├── underscore.apl └── vec.apl /.gitignore: -------------------------------------------------------------------------------- 1 | aplparse 2 | test 3 | *~ 4 | MLB -------------------------------------------------------------------------------- /APL_PARSE.sig: -------------------------------------------------------------------------------- 1 | signature APL_PARSE = sig 2 | 3 | type class 4 | val fun1 : class 5 | val fun2 : class 6 | val value : class 7 | val opr1fun1 : class 8 | val opr1fun2 : class 9 | val opr2fun1 : class 10 | val opr2fun2 : class 11 | 12 | type env 13 | val emp : env 14 | val env0 : env 15 | val plus : env * env -> env 16 | val add : string * class list -> env -> env 17 | 18 | exception ParseErr of Region.loc * string 19 | val parse : env -> (AplLex.token * Region.reg) list -> AplAst.exp * env 20 | 21 | val seq : AplAst.exp * AplAst.exp -> AplAst.exp 22 | end 23 | -------------------------------------------------------------------------------- /AplAst.sml: -------------------------------------------------------------------------------- 1 | structure AplAst = struct 2 | structure L = AplLex 3 | type token = L.token 4 | type reg = Region.reg 5 | type var = string 6 | 7 | datatype valence = MONADIC | DYADIC 8 | 9 | datatype id = Symb of token 10 | | Var of var 11 | 12 | datatype exp = 13 | IntE of string * reg 14 | | DoubleE of string * reg 15 | | ComplexE of string * reg 16 | | StrE of word list * reg 17 | | VecE of exp list * reg 18 | | IdE of id * reg 19 | | LambE of (int*int) * exp * reg (* ints specify valence of operator and derived function *) 20 | | App1E of exp * exp * reg (* apply monadic function or operator *) 21 | | App2E of exp * exp * exp * reg (* apply dyadic function or operator *) 22 | | AppOpr1E of int list * exp * exp * reg (* apply monadic operator; int list contains the possible valences of the resulting function *) 23 | | AppOpr2E of int list * exp * exp * exp * reg (* apply dyadic operator *) 24 | | AssignE of var * exp option list * exp * reg 25 | | SeqE of exp list * reg 26 | | ParE of exp * reg 27 | | GuardE of exp * exp * reg 28 | | IndexE of exp * exp option list * reg 29 | | UnresE of exp list * reg 30 | | GenericE of (valence -> exp) * reg (* valence generic parse trees *) 31 | 32 | fun pr_id (Var v) = v 33 | | pr_id (Symb s) = L.pr_token s 34 | 35 | fun pr_ints vs = String.concatWith "," (List.map Int.toString vs) 36 | 37 | fun pr_exp e = 38 | case e of 39 | IntE (s,_) => s 40 | | DoubleE (s,_) => s 41 | | ComplexE (s,_) => s 42 | | StrE (ws,_) => L.pr_chars ws 43 | | VecE (es,_) => "Vec[" ^ pr_exps es ^ "]" 44 | | IdE (id,_) => pr_id id 45 | | LambE ((v1,v2),e,_) => "Lam[" ^ pr_ints[v1,v2] ^ "](" ^ pr_exp e ^ ")" 46 | | App1E (e0,e,_) => "App1(" ^ pr_exp e0 ^ "," ^ pr_exp e ^ ")" 47 | | App2E (e0,e1,e2,_) => "App2(" ^ pr_exp e0 ^ "," ^ pr_exp e1 ^ "," ^ pr_exp e2 ^ ")" 48 | | AppOpr1E (vs,e0,e1,_) => "AppOpr1[" ^ pr_ints vs ^ "](" ^ pr_exp e0 ^ "," ^ pr_exp e1 ^ ")" 49 | | AppOpr2E (vs,e0,e1,e2,_) => "AppOpr2[" ^ pr_ints vs ^ "](" ^ pr_exp e0 ^ "," ^ pr_exp e1 ^ "," ^ pr_exp e2 ^ ")" 50 | | AssignE (v,nil,e,_) => "Assign(" ^ v ^ "," ^ pr_exp e ^ ")" 51 | | AssignE (v,is,e,_) => "Assign(" ^ v ^ "," ^ pr_sqindices is ^ "," ^ pr_exp e ^ ")" 52 | | SeqE (es,_) => "[" ^ pr_exps es ^ "]" 53 | | ParE (e,_) => "Par(" ^ pr_exp e ^ ")" 54 | | GuardE (e1,e2,_) => "Guard(" ^ pr_exp e1 ^ "," ^ pr_exp e2 ^ ")" 55 | | IndexE (e,is,_) => "Index(" ^ pr_exp e ^ "," ^ pr_sqindices is ^ ")" 56 | | UnresE (es,_) => "Unres[" ^ pr_exps es ^ "]" 57 | | GenericE (f,_) => "Generic[MONADIC=" ^ pr_exp (f MONADIC) ^ ", DYADIC=" ^ pr_exp (f DYADIC) ^ "]" 58 | 59 | and pr_sqindices is = "[" ^ pr_indices is ^ "]" 60 | 61 | and pr_exps nil = "" 62 | | pr_exps [e] = pr_exp e 63 | | pr_exps (e::es) = pr_exp e ^ "," ^ pr_exps es 64 | 65 | and pr_optexp NONE = "" 66 | | pr_optexp (SOME e) = pr_exp e 67 | 68 | and pr_indices idxs = String.concatWith ";" (List.map pr_optexp idxs) 69 | 70 | fun reg_exp e = 71 | case e of 72 | IntE (_,r) => r 73 | | DoubleE (_,r) => r 74 | | ComplexE (_,r) => r 75 | | StrE (_,r) => r 76 | | VecE (_,r) => r 77 | | IdE (_,r) => r 78 | | LambE (_,_,r) => r 79 | | App1E (_,_,r) => r 80 | | App2E (_,_,_,r) => r 81 | | AppOpr1E (_,_,_,r) => r 82 | | AppOpr2E (_,_,_,_,r) => r 83 | | AssignE (_,_,_,r) => r 84 | | SeqE (_,r) => r 85 | | ParE (_,r) => r 86 | | GuardE (_,_,r) => r 87 | | IndexE (_,_,r) => r 88 | | UnresE (_,r) => r 89 | | GenericE (_,r) => r 90 | 91 | and reg_exps r nil = r 92 | | reg_exps r (e::es) = reg_exps (Region.plus "reg_exps" r (reg_exp e)) es 93 | 94 | end 95 | -------------------------------------------------------------------------------- /AplLex.sml: -------------------------------------------------------------------------------- 1 | structure AplLex = struct 2 | 3 | datatype token = 4 | Alpha 5 | | Beta 6 | | Gamma 7 | | Delta 8 | | Epsilon 9 | | Zeta 10 | | Eta 11 | | Kappa 12 | | Lambda 13 | | Mu 14 | | Nu 15 | | Omega 16 | | Alphaalpha 17 | | Omegaomega 18 | | Iota 19 | | Rho 20 | | Rtack 21 | | Ltack 22 | | Quad 23 | | Quaddiv 24 | | Quotquad 25 | | Quot 26 | | Max | Min 27 | | Enclose | Disclose 28 | | Slash | Backslash 29 | | Slashbar | Backslashbar 30 | | Squad 31 | | Gradeup | Gradedown 32 | | Each 33 | | Add 34 | | Sub 35 | | Times 36 | | Div 37 | | Pow 38 | | Lbra | Rbra 39 | | Lpar | Rpar 40 | | Lsqbra | Rsqbra 41 | | Semicolon | Colon 42 | | Cat | Vcat 43 | | Trans 44 | | Rot | Vrot 45 | | Larrow | Rarrow 46 | | Lt | Gt | Lteq | Gteq | Eq | Neq 47 | | Zilde 48 | | Circ 49 | | Circstar 50 | | Take | Drop 51 | | Or | And 52 | | Nor | Nand 53 | | Match | Nmatch 54 | | Qmark 55 | | Ring 56 | | Dot 57 | | Macron 58 | | Diamond 59 | | In 60 | | Nabla 61 | | Tilde 62 | | Intersect | Union 63 | | Comment 64 | | Newline 65 | | Letter of char 66 | | Digit of char 67 | | Id of string 68 | | Int of string 69 | | Double of string 70 | | Complex of string 71 | | Chars of word list 72 | | Dollar 73 | | Underscore 74 | | StarDia 75 | | TildeDia 76 | | Pipe 77 | | Fac 78 | | Thorn 79 | 80 | fun complexFromString s = 81 | let fun fixDot s = 82 | case explode s of 83 | #"." :: rest => implode (#"0" :: #"." :: rest) 84 | | #"-":: #"." :: rest => implode (#"-" :: #"0" :: #"." :: rest) 85 | | _ => s 86 | in case String.tokens (fn c => c = #"j") s of 87 | [r,i] => (case (Real.fromString r, Real.fromString i) of 88 | (SOME r, SOME i) => SOME(r,i) 89 | | _ => NONE) 90 | | _ => NONE 91 | end 92 | 93 | (* pr_chars : word list -> string *) 94 | fun pr_chars ws = 95 | if List.all (fn w => w < 0w128) ws then 96 | "'" ^ implode (List.map (Char.chr o Word.toInt) ws) ^ "'" 97 | else "Chars(" ^ String.concatWith "," (List.map Word.toString ws) ^ ")" 98 | 99 | (* pr_token : token -> string *) 100 | fun pr_token t = 101 | case t of 102 | Alpha => "Alpha" 103 | | Beta => "Beta" 104 | | Gamma => "Gamma" 105 | | Delta => "Delta" 106 | | Epsilon => "Epsilon" 107 | | Zeta => "Zeta" 108 | | Eta => "Eta" 109 | | Kappa => "Kappa" 110 | | Lambda => "Lambda" 111 | | Mu => "Mu" 112 | | Nu => "Nu" 113 | | Omega => "Omega" 114 | | Alphaalpha => "Alphaalpha" 115 | | Omegaomega => "Omegaomega" 116 | | Iota => "Iota" 117 | | Rho => "Rho" 118 | | Rtack => "Rtack" 119 | | Ltack => "Ltack" 120 | | Quad => "Quad" 121 | | Quaddiv => "Quaddiv" 122 | | Quotquad => "Quotquad" 123 | | Quot => "Quot" 124 | | Max => "Max" 125 | | Min => "Min" 126 | | Enclose => "Enclose" 127 | | Disclose => "Disclose" 128 | | Slash => "Slash" 129 | | Backslash => "Backslash" 130 | | Slashbar => "Slashbar" 131 | | Backslashbar => "Backslashbar" 132 | | Squad => "Squad" 133 | | Gradeup => "Gradeup" 134 | | Gradedown => "Gradedown" 135 | | Each => "Each" 136 | | Add => "Add" 137 | | Sub => "Sub" 138 | | Times => "Times" 139 | | Div => "Div" 140 | | Pow => "Pow" 141 | | Lbra => "Lbra" 142 | | Rbra => "Rbra" 143 | | Lpar => "Lpar" 144 | | Rpar => "Rpar" 145 | | Lsqbra => "Lsqbra" 146 | | Rsqbra => "Rsqbra" 147 | | Semicolon => "Semicolon" 148 | | Colon => "Colon" 149 | | Cat => "Cat" 150 | | Vcat => "Vcat" 151 | | Trans => "Trans" 152 | | Rot => "Rot" 153 | | Vrot => "Vrot" 154 | | Larrow => "Larrow" 155 | | Rarrow => "Rarrow" 156 | | Lt => "Lt" 157 | | Gt => "Gt" 158 | | Lteq => "Lteq" 159 | | Gteq => "Gteq" 160 | | Eq => "Eq" 161 | | Neq => "Neq" 162 | | Zilde => "Zilde" 163 | | Circ => "Circ" 164 | | Circstar => "Circstar" 165 | | Take => "Take" 166 | | Drop => "Drop" 167 | | Or => "Or" 168 | | And => "And" 169 | | Nor => "Nor" 170 | | Nand => "Nand" 171 | | Match => "Match" 172 | | Nmatch => "Nmatch" 173 | | Qmark => "Qmark" 174 | | Ring => "Ring" 175 | | Dot => "Dot" 176 | | Macron => "Macron" 177 | | Diamond => "Diamond" 178 | | In => "In" 179 | | Nabla => "Nabla" 180 | | Tilde => "Tilde" 181 | | Intersect => "Intersect" 182 | | Union => "Union" 183 | | Comment => "Comment" 184 | | Newline => "Newline" 185 | | Letter c => "Letter(" ^ String.str c ^ ")" 186 | | Digit c => "Digit(" ^ String.str c ^ ")" 187 | | Id s => "Id(" ^ s ^ ")" 188 | | Int i => i 189 | | Double r => r 190 | | Complex c => c 191 | | Chars ws => pr_chars ws 192 | | Dollar => "Dollar" 193 | | Underscore => "Underscore" 194 | | StarDia => "StarDia" 195 | | TildeDia => "TildeDia" 196 | | Pipe => "Pipe" 197 | | Fac => "Fac" 198 | | Thorn => "Thorn" 199 | 200 | type filename = Region.filename 201 | type loc = Region.loc 202 | type reg = Region.reg 203 | fun loc0 f : loc = (1,0,f) (* line 1, char 0 *) 204 | 205 | datatype state = CommentS 206 | | StartS 207 | | SymbS of token * loc * loc (* for lexing Alphaalpha, Omegaomega, Quad-Id *) 208 | | IntS of string * loc * loc 209 | | DoubleS of string * loc * loc 210 | | ComplexJS of string * loc * loc 211 | | ComplexIS of string * loc * loc 212 | | ComplexS of string * loc * loc 213 | | CharsS of word list * loc * loc 214 | | IdS of string * loc * loc 215 | 216 | (* getChar : word -> char option *) 217 | fun getChar w = 218 | if w < 0w128 then SOME(Char.chr(Word.toInt w)) 219 | else NONE 220 | 221 | (* lexWord : word -> token optin *) 222 | fun lexWord w = 223 | case w of 224 | 0wx237A => SOME Alpha 225 | | 0wx03B2 => SOME Beta 226 | | 0wx03B3 => SOME Gamma 227 | | 0wx03B4 => SOME Delta 228 | | 0wx03B5 => SOME Epsilon 229 | | 0wx03B6 => SOME Zeta 230 | | 0wx03B7 => SOME Eta 231 | | 0wx03BA => SOME Kappa 232 | | 0wx03BB => SOME Lambda 233 | | 0wx03BC => SOME Mu 234 | | 0wx03BD => SOME Nu 235 | | 0wx2373 => SOME Iota 236 | | 0wx2375 => SOME Omega 237 | | 0wx2374 => SOME Rho 238 | | 0wx2363 => SOME StarDia 239 | | 0wx22A2 => SOME Rtack 240 | | 0wx22A3 => SOME Ltack 241 | | 0wx22C6 => SOME Pow 242 | | 0wx2368 => SOME TildeDia 243 | | 0wxAF => SOME Macron 244 | | 0wx236C => SOME Zilde 245 | | 0wxA8 => SOME Each 246 | | 0wx233F => SOME Slashbar 247 | | 0wx2340 => SOME Backslashbar 248 | | 0wx2337 => SOME Squad 249 | | 0wx2264 => SOME Lteq 250 | | 0wx2265 => SOME Gteq 251 | | 0wx2260 => SOME Neq 252 | | 0wx2228 => SOME Or 253 | | 0wx2227 => SOME And 254 | | 0wx2371 => SOME Nor 255 | | 0wx2372 => SOME Nand 256 | | 0wxF7 => SOME Div 257 | | 0wxD7 => SOME Times 258 | | 0wx2212 => SOME Sub 259 | | 0wx220A => SOME In 260 | | 0wx2208 => SOME In 261 | | 0wx2191 => SOME Take 262 | | 0wx2193 => SOME Drop 263 | | 0wx25CB => SOME Circ 264 | | 0wx2308 => SOME Max 265 | | 0wx230A => SOME Min 266 | | 0wx2207 => SOME Nabla 267 | | 0wx2218 => SOME Ring 268 | | 0wx2282 => SOME Enclose 269 | | 0wx2283 => SOME Disclose 270 | | 0wx2229 => SOME Intersect 271 | | 0wx222A => SOME Union 272 | | 0wx2352 => SOME Gradedown 273 | | 0wx234B => SOME Gradeup 274 | | 0wx2349 => SOME Trans 275 | | 0wx233D => SOME Rot 276 | | 0wx2296 => SOME Vrot 277 | | 0wx235F => SOME Circstar 278 | | 0wx2339 => SOME Quaddiv 279 | | 0wx236A => SOME Vcat 280 | | 0wx2261 => SOME Match 281 | | 0wx2262 => SOME Nmatch 282 | | 0wx22C4 => SOME Diamond 283 | | 0wx2190 => SOME Larrow 284 | | 0wx2192 => SOME Rarrow 285 | | 0wx235D => SOME Comment 286 | | 0wx2395 => SOME Quad 287 | | 0wx235E => SOME Quotquad 288 | | 0wx2355 => SOME Thorn 289 | | _ => 290 | case getChar w of 291 | SOME #"{" => SOME Lbra 292 | | SOME #"}" => SOME Rbra 293 | | SOME #"(" => SOME Lpar 294 | | SOME #")" => SOME Rpar 295 | | SOME #"." => SOME Dot 296 | | SOME #"," => SOME Cat 297 | | SOME #"*" => SOME Pow 298 | | SOME #"/" => SOME Slash 299 | | SOME #"\\" => SOME Backslash 300 | | SOME #"?" => SOME Qmark 301 | | SOME #"=" => SOME Eq 302 | | SOME #"<" => SOME Lt 303 | | SOME #">" => SOME Gt 304 | | SOME #"+" => SOME Add 305 | | SOME #"-" => SOME Sub 306 | | SOME #"~" => SOME Tilde 307 | | SOME #"\n" => SOME Newline 308 | | SOME #"[" => SOME Lsqbra 309 | | SOME #"]" => SOME Rsqbra 310 | | SOME #":" => SOME Colon 311 | | SOME #";" => SOME Semicolon 312 | | SOME #"$" => SOME Dollar 313 | | SOME #"_" => SOME Underscore 314 | | SOME #"|" => SOME Pipe 315 | | SOME #"!" => SOME Fac 316 | | SOME #"'" => SOME Quot 317 | | SOME c => 318 | if Char.isDigit c then SOME(Digit c) 319 | else if Char.isAlpha c then SOME(Letter c) 320 | else NONE 321 | | _ => NONE 322 | 323 | (* isWhiteSpace : word -> bool *) 324 | fun isWhiteSpace w = 325 | case getChar w of 326 | SOME c => Char.isSpace c 327 | | NONE => false 328 | 329 | (* lexError : loc -> string -> 'a *) 330 | fun lexError loc s = 331 | let val msg = "Lexical error at location " ^ Region.ppLoc loc ^ ": " ^ s 332 | in raise Fail msg 333 | end 334 | 335 | type procstate = (token * reg) list * state * loc 336 | 337 | fun last "" = NONE 338 | | last s = SOME(String.sub(s,size s - 1)) 339 | 340 | (* process : word * procstate -> procstate *) 341 | fun process0 (w,(tokens,state,loc)) = 342 | let val elem = lexWord w 343 | fun process (tokens,state,loc) = 344 | case (state, elem) of 345 | (CommentS, SOME Newline) => ((Newline,(loc,loc))::tokens, StartS, Region.newline loc) 346 | | (CommentS, _ ) => (tokens, state, Region.next loc) 347 | | (StartS, SOME Macron) => (tokens, IntS("-",loc,loc), Region.next loc) 348 | | (StartS, SOME (Digit c)) => (tokens, IntS(String.str c,loc,loc), Region.next loc) 349 | | (IntS(s,l0,_), SOME (Digit c)) => (tokens, IntS(s ^ String.str c,l0,loc), Region.next loc) 350 | | (DoubleS(s,l0,_), SOME (Digit c)) => (tokens, DoubleS(s ^ String.str c,l0,loc), Region.next loc) 351 | | (IntS(s,l0,_), SOME (Letter c)) => if c = #"j" orelse c = #"J" then (tokens,ComplexJS(s ^ "j",l0,loc),Region.next loc) 352 | else lexError loc "ilformed integer" 353 | | (DoubleS(s,l0,_), SOME (Letter c)) => if c = #"j" orelse c = #"J" then (tokens,ComplexJS(s ^ "j",l0,loc),Region.next loc) 354 | else lexError loc "ilformed double" 355 | | (ComplexJS(s,l0,_), SOME Macron) => (tokens, ComplexIS(s ^ "-",l0,loc), Region.next loc) 356 | | (ComplexJS(s,l0,_), SOME (Digit c))=> (tokens, ComplexIS(s ^ String.str c,l0,loc), Region.next loc) 357 | | (ComplexJS(s,l0,_), SOME Dot) => (tokens, ComplexS(s ^ "0.",l0,loc), Region.next loc) 358 | | (ComplexIS(s,l0,_),SOME (Digit c)) => (tokens, ComplexIS(s ^ String.str c,l0,loc), Region.next loc) 359 | | (ComplexIS(s,l0,_), SOME Dot) => (tokens, ComplexS(if last s = SOME #"-" then s ^ "0." else s ^ ".",l0,loc), Region.next loc) 360 | | (ComplexS(s,l0,_), SOME (Digit c)) => (tokens, ComplexS(s ^ String.str c,l0,loc), Region.next loc) 361 | | (StartS, SOME Dot) => (tokens, SymbS(Dot,loc,loc), Region.next loc) 362 | | (IntS(s,l0,_), SOME Dot) => (tokens, DoubleS(if s = "-" then "-0." else s ^ ".",l0,loc), Region.next loc) 363 | | (StartS, SOME (Letter c)) => (tokens, IdS(String.str c,loc,loc), Region.next loc) 364 | | (StartS, SOME Dollar) => (tokens, IdS("$",loc,loc), Region.next loc) 365 | | (StartS, SOME Underscore) => (tokens, IdS("_",loc,loc), Region.next loc) 366 | | (IdS(s,l0,_), SOME (Letter c)) => (tokens, IdS(s ^ String.str c,l0,loc), Region.next loc) 367 | | (IdS(s,l0,_), SOME Underscore) => (tokens, IdS(s ^ "_",l0,loc), Region.next loc) 368 | | (IdS(s,l0,_), SOME (Digit c)) => (tokens, IdS(s ^ String.str c,l0,loc), Region.next loc) 369 | | (StartS, SOME Alpha) => (tokens, SymbS(Alpha,loc,loc), Region.next loc) 370 | | (StartS, SOME Omega) => (tokens, SymbS(Omega,loc,loc), Region.next loc) 371 | | (StartS, SOME Quad) => (tokens, SymbS(Quad,loc,loc), Region.next loc) 372 | | (SymbS(Alpha,l0,_), SOME Alpha) => ((Alphaalpha,(l0,loc))::tokens, StartS, Region.next loc) 373 | | (SymbS(Omega,l0,_), SOME Omega) => ((Omegaomega,(l0,loc))::tokens, StartS, Region.next loc) 374 | | (SymbS(Quad,l0,_), SOME (Letter c))=> (tokens, IdS("Quad$" ^ String.str c,l0,loc), Region.next loc) 375 | | (SymbS(Dot,l0,_), SOME (Digit c)) => (tokens, DoubleS("0." ^ String.str c,l0,loc), Region.next loc) 376 | | (SymbS(t,l0,l1), _) => process'((t,(l0,l1))::tokens, StartS, loc) 377 | | (IntS(s,l0,l1), _) => 378 | (case Int32.fromString s of 379 | SOME _ => process'((Int s,(l0,l1))::tokens, StartS, loc) 380 | | NONE => lexError loc ("ilformed integer " ^ s)) 381 | | (DoubleS(s,l0,l1), _) => 382 | (case Real.fromString s of 383 | SOME _ => process'((Double s,(l0,l1)) :: tokens, StartS, loc) 384 | | NONE => lexError loc ("ilformed double " ^ s)) 385 | | (ComplexIS(s,l0,l1), _) => 386 | (case complexFromString s of 387 | SOME _ => process'((Complex s,(l0,l1)) :: tokens, StartS, loc) 388 | | NONE => lexError loc ("ilformed complex number " ^ s)) 389 | | (ComplexS(s,l0,l1), _) => 390 | (case complexFromString s of 391 | SOME _ => process'((Complex s,(l0,l1)) :: tokens, StartS, loc) 392 | | NONE => lexError loc ("non-wellformed complex number " ^ s)) 393 | | (ComplexJS(s,l0,l1), _) => 394 | (case complexFromString (s ^ "0") of 395 | SOME _ => process'((Complex s,(l0,l1)) :: tokens, StartS, loc) 396 | | NONE => lexError loc ("malformed complex number " ^ s)) 397 | | (IdS(s,l0,l1), _) => process'((Id s,(l0,l1))::tokens, StartS, loc) 398 | | (StartS, SOME Comment) => (tokens,CommentS, Region.next loc) 399 | | (StartS, SOME Quot) => (tokens,CharsS(nil,loc,loc), Region.next loc) 400 | | (CharsS(ws,l0,l1),SOME Quot) => ((Chars(rev ws),(l0,loc))::tokens, StartS, Region.next loc) 401 | | (CharsS(ws,l0,l1), _) => (tokens,CharsS(w::ws,l0,loc), Region.next loc) 402 | | (StartS, SOME s) => ((s,(loc,loc))::tokens,StartS, 403 | if s = Newline then Region.newline loc 404 | else Region.next loc) 405 | | (StartS, NONE) => if isWhiteSpace w then (tokens,state,Region.next loc) 406 | else lexError loc ("don't know what to do with " ^ Word.toString w) 407 | and process'(tokens,s,loc) = 408 | case elem of 409 | SOME Comment => (tokens,CommentS,loc) 410 | | _ => process(tokens,s,loc) 411 | in 412 | process(tokens,state,loc) 413 | end 414 | 415 | (* pr_tokens : token list -> string *) 416 | fun pr_tokens ts = String.concatWith " " (List.map pr_token ts) 417 | 418 | (* lex : string -> string -> (token * reg) list *) 419 | fun lex filename s = 420 | let val s = Utf8.fromString (s^" ") (* pad some whitespace to keep the lexer happy *) 421 | val (tokens,state,_) = Utf8.foldl process0 (nil,StartS,Region.loc0 filename) s 422 | in rev tokens 423 | end 424 | end 425 | -------------------------------------------------------------------------------- /AplParse.sml: -------------------------------------------------------------------------------- 1 | structure AplParse : APL_PARSE = struct 2 | 3 | val p_debug = false 4 | fun debug f = 5 | if p_debug then print(f()) 6 | else () 7 | 8 | open AplAst 9 | structure PComb = ParseComb(type token=token 10 | val pr_token = AplLex.pr_token) 11 | 12 | type reg = Region.reg 13 | val botreg = (Region.botloc,Region.botloc) 14 | 15 | open PComb infix >>> ->> >>- ?? ??? || oo oor 16 | 17 | (* eat Newline's from the list of tokens *) 18 | (* p_ws : unit p *) 19 | fun p_ws ts = (eat L.Newline ?? p_ws) #1 ts 20 | 21 | (* Seperators: either whitespace or a Diamond *) 22 | (* p_sep : unit p *) 23 | val p_sep = p_ws || eat L.Diamond 24 | 25 | (* p_id : string p *) 26 | fun p_id nil = NO (Region.botloc,fn () => "expecting identifier but found end-of-file") 27 | | p_id ((L.Id id,r)::ts) = OK(id,r,ts) 28 | | p_id ((t,r:reg)::_) = NO (#1 r,fn() => ("expecting identifier but found token " ^ AplLex.pr_token t)) 29 | 30 | (* p_quad : string p *) 31 | fun p_quad nil = NO (Region.botloc,fn () => "expecting Quad or identifier but found end-of-file") 32 | | p_quad ((L.Quad,r)::ts) = OK("$Quad",r,ts) 33 | | p_quad ((t,r:reg)::_) = NO (#1 r,fn() => ("expecting Quad or identifier but found token " ^ AplLex.pr_token t)) 34 | 35 | (* p_double : double p *) 36 | fun p_double nil = NO (Region.botloc,fn () => "expecting double but found end-of-file") 37 | | p_double ((L.Double d,r)::ts) = OK(d,r,ts) 38 | | p_double ((t,r:reg)::_) = NO (#1 r, fn() => ("expecting double but found token " ^ AplLex.pr_token t)) 39 | 40 | (* p_complex : complex p *) 41 | fun p_complex nil = NO (Region.botloc,fn () => "expecting complex number but found end-of-file") 42 | | p_complex ((L.Complex d,r)::ts) = OK(d,r,ts) 43 | | p_complex ((t,r:reg)::_) = NO (#1 r, fn() => ("expecting complex number but found token " ^ AplLex.pr_token t)) 44 | 45 | (* p_int : int p *) 46 | fun p_int nil = NO (Region.botloc,fn () => "expecting integer but found end-of-file") 47 | | p_int ((L.Int i,r)::ts) = OK(i,r,ts) 48 | | p_int ((t,r:reg)::_) = NO (#1 r, fn() => ("expecting integer but found token " ^ AplLex.pr_token t)) 49 | 50 | (* p_string : word list p *) 51 | fun p_string nil = NO (Region.botloc,fn () => "expecting string but found end-of-file") 52 | | p_string ((L.Chars ws,r)::ts) = OK(ws,r,ts) 53 | | p_string ((t,r:reg)::_) = NO (#1 r, fn() => ("expecting string but found token " ^ AplLex.pr_token t)) 54 | 55 | (* is_symb : Lexer.token -> bool *) 56 | fun is_symb t = 57 | case t of 58 | L.Alpha => true 59 | | L.Alphaalpha => true 60 | | L.Omega => true 61 | | L.Omegaomega => true 62 | | L.Rho => true 63 | | L.Rtack => true 64 | | L.Ltack => true 65 | | L.Iota => true 66 | | L.Max => true 67 | | L.Min => true 68 | | L.Enclose => true 69 | | L.Disclose => true 70 | | L.Slash => true 71 | | L.Slashbar => true 72 | | L.Backslash => true 73 | | L.Squad => true 74 | | L.Gradeup => true 75 | | L.Gradedown => true 76 | | L.Each => true 77 | | L.Add => true 78 | | L.Sub => true 79 | | L.Times => true 80 | | L.Div => true 81 | | L.Dot => true 82 | | L.Pow => true 83 | | L.Qmark => true 84 | | L.Cat => true 85 | | L.Vcat => true 86 | | L.Trans => true 87 | | L.Rot => true 88 | | L.Vrot => true 89 | | L.Lt => true 90 | | L.Gt => true 91 | | L.Lteq => true 92 | | L.Gteq => true 93 | | L.Eq => true 94 | | L.Neq => true 95 | | L.Zilde => true 96 | | L.Circ => true 97 | | L.Circstar => true 98 | | L.Take => true 99 | | L.Drop => true 100 | | L.Or => true 101 | | L.And => true 102 | | L.Nor => true 103 | | L.Nand => true 104 | | L.Match => true 105 | | L.Nmatch => true 106 | | L.Tilde => true 107 | | L.Intersect => true 108 | | L.Union => true 109 | | L.StarDia => true 110 | | L.Ring => true 111 | | L.Pipe => true 112 | | L.Fac => true 113 | | L.In => true 114 | | L.Thorn => true 115 | | _ => false 116 | 117 | (* p_symb : token p *) 118 | fun p_symb nil = NO (Region.botloc,fn()=>"reached end-of-file") 119 | | p_symb ((t,r:reg)::ts) = 120 | if is_symb t then OK(t,r,ts) 121 | else NO (#1 r, 122 | fn () => ("expecting symbol but found token " ^ 123 | AplLex.pr_token t)) 124 | 125 | (* APL Parsing *) 126 | 127 | (* Grammar: 128 | 129 | SEP := DIAMOND | NEWLINE 130 | 131 | body ::= guard 132 | | SEP body 133 | 134 | guard ::= expr <: expr> 135 | 136 | expr ::= assignment 137 | | seq 138 | 139 | assignment ::= ID < [ indices ] > LARROW expr 140 | 141 | seq ::= item < seq > 142 | 143 | item ::= indexable < [ indices ] > 144 | 145 | indices ::= expr < ; indices > 146 | | ; indices 147 | 148 | indexable ::= INTEGER | DOUBLE | STRING | SYMBOL 149 | | ( expr ) | { body } 150 | *) 151 | 152 | (* seq : exp * exp -> exp *) 153 | fun seq (SeqE (es1,r1), SeqE (es2,r2)) = SeqE(es1@es2,Region.plus "seq1" r1 r2) 154 | | seq (SeqE (es,r), e) = SeqE(es @ [e],Region.plus "seq2" r (reg_exp e)) 155 | | seq (e, SeqE (es,r)) = SeqE(e::es,Region.plus "seq3" (reg_exp e) r) 156 | | seq (e1,e2) = SeqE([e1,e2],Region.plus "seq4"(reg_exp e1)(reg_exp e2)) 157 | 158 | (* unres : exp * exp -> exp *) 159 | fun unres (UnresE (es1,r1), UnresE (es2,r2)) = UnresE(es1@es2,Region.plus "unres1"r1 r2) 160 | | unres (UnresE (es,r), e) = UnresE(es @ [e],Region.plus "unres2" r (reg_exp e)) 161 | | unres (e, UnresE (es,r)) = UnresE(e::es,Region.plus "unres3" (reg_exp e) r) 162 | | unres (e1,e2) = UnresE([e1,e2],Region.plus "unres4" (reg_exp e1)(reg_exp e2)) 163 | 164 | (* exp parsers *) 165 | fun p_body ts = 166 | (((((p_guard ?? (p_sep ->> p_body)) seq) ?? p_ws) #1) 167 | || (p_sep ->> p_body)) ts 168 | 169 | and p_guard ts = 170 | (p_expr ??? (eat L.Colon ->> p_expr)) GuardE ts 171 | 172 | and p_expr ts = 173 | ( p_assignment 174 | || (p_seq ?? p_assignment) seq 175 | ) ts 176 | 177 | and p_assignment ts = 178 | ( ((((p_id || p_quad) oo (fn x => (x,nil))) ?? p_sqindices) (fn ((x,_),xs) => (x,xs))) >>- 179 | eat L.Larrow >>> p_expr oor (fn (((x,xs),b),r) => AssignE(x,xs,b,r)) ) ts 180 | 181 | and p_seq ts = 182 | (p_item ?? p_seq) unres ts 183 | 184 | and p_sqindices ts = 185 | (eat L.Lsqbra ->> p_indices >>- eat L.Rsqbra) ts 186 | 187 | and p_item ts = 188 | (p_indexable ??? p_sqindices) IndexE ts 189 | 190 | and p_indices ts = 191 | ( (p_expr oo (fn x => [SOME x]) ?? ((eat L.Semicolon ->> p_indices) || (eat L.Semicolon oo (fn() => [NONE])))) (op @) 192 | || (eat L.Semicolon oo (fn () => [NONE]) ?? p_indices) (op @) 193 | ) ts 194 | 195 | and p_indexable ts = 196 | ( (p_int oor IntE) 197 | || (p_double oor DoubleE) 198 | || (p_complex oor ComplexE) 199 | || (p_string oor StrE) 200 | || (p_symb oor (fn (a,r) => IdE(Symb a,r))) 201 | || (p_id oor (fn (a,r) => IdE(Var a,r))) 202 | || ((eat L.Lpar ->> p_expr >>- eat L.Rpar) oor ParE) 203 | || ((eat L.Lbra ->> p_body >>- eat L.Rbra) oor (fn (e,r) => LambE((~1,~1),e,r))) 204 | ) ts 205 | 206 | (* parse0 : (token * reg) list -> (exp, locerr) either *) 207 | fun parse0 ts = 208 | case p_body ts of 209 | OK(ast,r,ts) => 210 | (case ts of nil => OK ast 211 | | ((t,r)::_) => NO (#1 r, fn() => ("token " ^ AplLex.pr_token t 212 | ^ " not expected"))) 213 | | NO l => NO l 214 | 215 | structure Class = struct 216 | 217 | (* Operators may take functions or arrays as arguments. 218 | * 219 | * We divide LambE bodies into functions and operators depending on 220 | * what operator- and function-argument references they contain: 221 | * Omega Alpha Omegaomega Alphaalpha Class Desciption 222 | * _ 0 0 0 (0,1) Monadic function 223 | * _ x 0 0 (0,2) Dyadic function 224 | * _ 0 0 x (1,1) Monadic operator generating monadic function 225 | * _ x 0 x (1,2) Monadic operator generating dyadic function 226 | * _ 0 x _ (2,1) Dyadic operator generating monadic function 227 | * _ x x _ (2,2) Dyadic operator generating dyadic function 228 | *) 229 | 230 | type class = int * int (* partial order of valence pairs *) 231 | val bot = (0,0) 232 | val omega = (0,1) 233 | val alpha = (0,2) 234 | val alphaalpha = (1,0) 235 | val omegaomega = (2,0) 236 | fun mx x y = if Int.>(x,y) then x else y 237 | fun lub (x1,y1) (x2,y2) = (mx x1 x2, mx y1 y2) (* least upper bound *) 238 | 239 | (* classify: to be applied to the body of a lambda expression; returns a pair 240 | * of an operator valence and a function valence (0, 1, or 2). *) 241 | 242 | fun classify e : class = 243 | case e of 244 | IntE s => bot 245 | | DoubleE s => bot 246 | | ComplexE s => bot 247 | | VecE _ => bot 248 | | StrE s => bot 249 | | IdE(Symb L.Omega,_) => omega 250 | | IdE(Symb L.Alpha,_) => alpha 251 | | IdE(Symb L.Alphaalpha,_) => alphaalpha 252 | | IdE(Symb L.Omegaomega,_) => omegaomega 253 | | IdE _ => bot 254 | | LambE _ => bot (* don't go under a lambda *) 255 | | App1E (e0,e1,_) => lub (classify e0) (classify e1) 256 | | App2E (e0,e1,e2,_) => lub (classify e0) (lub (classify e1) (classify e2)) 257 | | AppOpr1E (_,e0,e1,_) => lub (classify e0) (classify e1) 258 | | AppOpr2E (_,e0,e1,e2,_) => lub (classify e0) (lub (classify e1) (classify e2)) 259 | | AssignE (v,is,e,_) => 260 | foldl(fn (NONE, a) => a 261 | | (SOME e, a) => lub a (classify e)) (classify e) is 262 | | SeqE(es,_) => foldl (fn (e,a) => lub a (classify e)) bot es 263 | | ParE(e,_) => classify e 264 | | GuardE (e1,e2,_) => lub (classify e1) (classify e2) 265 | | IndexE (e0,is,_) => 266 | foldl(fn (NONE, a) => a 267 | | (SOME e, a) => lub a (classify e)) (classify e0) is 268 | | UnresE(es,_) => foldl (fn (e,a) => lub a (classify e)) bot es 269 | | GenericE _ => raise Fail "classify:Generic" 270 | 271 | fun pr_class (x,y) = "Cls(" ^ Int.toString x ^ "," ^ Int.toString y ^ ")" 272 | 273 | val fun1 = (0,1) 274 | val fun2 = (0,2) 275 | val value = (0,0) 276 | val opr1fun1 = (1,1) 277 | val opr1fun2 = (1,2) 278 | val opr2fun1 = (2,1) 279 | val opr2fun2 = (2,2) 280 | 281 | fun pFun1 c = c=fun1 282 | fun pFun2 c = c=fun2 283 | fun pVal c = c=value 284 | fun pOpr1 c = c=opr1fun1 orelse c=opr1fun2 285 | fun pOpr2 c = c=opr2fun1 orelse c=opr2fun2 286 | fun appopr (_,n) = (0,n) 287 | 288 | end 289 | 290 | (* Utility function for resolving vectors in sequences of symbols and 291 | * immediate values *) 292 | fun resolve_vectors gs = 293 | let fun vec [(e,s)] = (e,s) 294 | | vec nil = raise Fail "resolve_vectors.vec" 295 | | vec ((e,s)::gs) = 296 | let val es = List.map #1 gs 297 | val r = reg_exps (reg_exp e) es 298 | in (VecE(e::es,r),s) 299 | end 300 | fun isValue (e,s) = s = [Class.value] 301 | val (gs,opt) = 302 | foldl (fn (g, (gs,NONE)) => if isValue g then (gs,SOME[g]) 303 | else (g::gs,NONE) 304 | | (g, (gs,SOME values)) => 305 | if isValue g then (gs,SOME(g::values)) 306 | else (g :: vec(rev values) :: gs,NONE)) 307 | (nil,NONE) gs 308 | val gs = case opt of 309 | SOME values => vec(rev values) :: gs 310 | | NONE => gs 311 | in rev gs 312 | end 313 | 314 | (* Resolve and eliminate Unres nodes in the tree. The resolution is done 315 | * right-to-left. Each term is ascribed a specifier (a set of classes). The specifiers 316 | * are used to resolve terms *) 317 | 318 | type spec = Class.class list 319 | type env = (id * spec) list 320 | val emp = [] 321 | fun lookup (E:env) id : spec option = 322 | case List.find (fn (id',_) => id=id') E of 323 | SOME (_,s) => SOME s 324 | | NONE => NONE 325 | fun add E (id,spec) = (id,spec)::E 326 | fun plus (E,E') = E'@E 327 | fun pr_spec s = "{" ^ String.concatWith "," (List.map Class.pr_class s) ^ "}" 328 | fun pr_env E = 329 | "{" ^ 330 | String.concatWith "," (List.map (fn (id,s) => (pr_id id ^ ":" ^ pr_spec s)) E) 331 | ^ "}" 332 | 333 | fun isKind p spec = List.exists p spec 334 | fun isFunKind p E id = 335 | case List.find (fn (id',_) => id = id') E of 336 | SOME (_,s) => isKind p s 337 | | NONE => false 338 | fun isVal (_,s) = isKind Class.pVal s 339 | fun isFun1 (_,s) = isKind Class.pFun1 s 340 | fun isFun2 (_,s) = isKind Class.pFun2 s 341 | fun isOpr1 (_,s) = isKind Class.pOpr1 s 342 | fun isOpr2 (_,s) = isKind Class.pOpr2 s 343 | fun isOpr g = isOpr1 g orelse isOpr2 g 344 | fun isFun g = isFun1 g orelse isFun2 g 345 | fun appopr s = List.map Class.appopr s 346 | val valuespec = [Class.value] 347 | val lamb_env = 348 | let open Class 349 | open L 350 | in [(Symb Alpha, valuespec), 351 | (Symb Omega, valuespec), 352 | (Symb Alphaalpha, [value,fun1,fun2]), 353 | (Symb Omegaomega, [value,fun1,fun2])] 354 | end 355 | fun pr_g (e,_) = pr_exp e 356 | fun reg_g (e,_) = reg_exp e 357 | val alpha_g = (IdE(Symb L.Alpha,botreg), valuespec) 358 | val omega_g = (IdE(Symb L.Omega,botreg), valuespec) 359 | 360 | (* Here is an example resolution: 361 | 362 | x1 x2 x3 f1(x4) : f1(x5) v(x6) 363 | x1 x2 1o2(x3) : f1(x4) v(app1E(x5,x6)) 364 | x1 x2 1o2(x3) : v(app1E(x4,app1E(x5,x6))) 365 | x1 f1(x2) 1o2(x3) : v(app1E(x4,app1E(x5,x6))) 366 | v(x1) f1(x2) 1o2(x3) : v(app1E(x4,app1E(x5,x6))) 367 | v(x1) f2(App1E(x3,x2)) v(app1E(x4,app1E(x5,x6))) 368 | v(App2E(App1E(x3,x2),app1E(x4,app1E(x5,x6)),x1)) 369 | *) 370 | 371 | fun resolveErr r msg = 372 | raise Fail ("Resolve Error: " ^ Region.pp r ^ ".\n " ^ msg) 373 | 374 | fun resolve E e = 375 | case e of 376 | IntE _ => (e,emp,valuespec) 377 | | DoubleE _ => (e,emp,valuespec) 378 | | ComplexE _ => (e,emp,valuespec) 379 | | VecE _ => (e,emp,valuespec) 380 | | StrE s => (e,emp,valuespec) 381 | | IdE (id,r) => 382 | (case lookup E id of 383 | SOME s => (e,emp,s) 384 | | NONE => resolveErr r ("The identifier " ^ pr_id id ^ " is not in the environment")) 385 | | LambE (_,e,r) => 386 | let val c = Class.classify e 387 | val (e,_,_) = resolve (lamb_env@E) e 388 | in (LambE(c,e,r),emp,[c]) 389 | end 390 | | App1E _ => raise Fail "resolve:App1" 391 | | App2E _ => raise Fail "resolve:App1" 392 | | AppOpr1E _ => raise Fail "resolve:App1" 393 | | AppOpr2E _ => raise Fail "resolve:App1" 394 | | AssignE (v,is,e,r) => 395 | let val (e,E',s) = resolve E e 396 | val (is,E1) = 397 | foldl (fn (NONE, (is,E0)) => (NONE::is,E0) 398 | | (SOME i, (is, E0)) => 399 | let val (i,E2,_) = resolve (E0@E'@E) i (* memo: maybe check for valuespec *) 400 | in (SOME i::is,E2@E0) 401 | end) (nil,emp) is 402 | val E' = [(Var v,s)] 403 | in (AssignE(v,rev is,e,r),E',s) 404 | end 405 | | SeqE (es,r) => 406 | let val (es,E,s) = 407 | foldl (fn (e,(es,E0,_)) => 408 | let val () = debug(fn () => "Resolving:\n " ^ pr_exp e ^ "\n") 409 | val (e,E2,s) = resolve (E0@E) e 410 | in (e::es,E2@E0,s) 411 | end) (nil,emp,valuespec) es 412 | in (SeqE (rev es,r),E,s) 413 | end 414 | | ParE (e,_) => 415 | let val (e,E,s) = resolve E e 416 | in (e,E,s) 417 | end 418 | | GuardE (e1,e2,r) => 419 | let val (e1,E1,_) = resolve E e1 (* memo: maybe check for valuespec *) 420 | val (e2,E2,s) = resolve (E1@E) e2 421 | in (GuardE(e1,e2,r),E2@E1,s) 422 | end 423 | | IndexE (e0,is,r) => 424 | let val (is,E1) = 425 | foldl (fn (NONE, (is,E0)) => (NONE::is,E0) 426 | | (SOME i, (is, E0)) => 427 | let val (i,E2,_) = resolve (E0@E) i (* memo: maybe check for valuespec *) 428 | in (SOME i::is,E2@E0) 429 | end) (nil,emp) is 430 | val (e0,E0,_) = resolve (E1@E) e0 (* memo: maybe check for valuespec *) 431 | in (IndexE(e0,rev is,r),E0@E1,valuespec) 432 | end 433 | | UnresE (es,r) => 434 | let val (gs, E') = foldl (fn (e,(gs,E')) => 435 | let val (e,E'',s) = resolve (E'@E) e 436 | in ((e,s)::gs,E''@E') 437 | end) (nil,emp) (rev es) 438 | val gs = resolve_vectors gs 439 | val (e,s) = res0 r (rev gs) 440 | in (e,E',s) 441 | end 442 | | GenericE _ => raise Fail "resolve:Generic" 443 | 444 | and appOpr1((e1,s1),(e2,_)) = 445 | let val derivedfunvalences = List.map #2 (appopr s1) 446 | val r = Region.plus "appOpr1" (reg_exp e2) (reg_exp e1) 447 | in (AppOpr1E(derivedfunvalences,e1,e2,r),appopr s1) 448 | end 449 | and appOpr2((e1,s1),(e2,_),(e3,_)) = 450 | let val derivedfunvalences = List.map #2 (appopr s1) 451 | val r = Region.plus "appOpr2" (reg_exp e2) (reg_exp e3) 452 | in (AppOpr2E(derivedfunvalences,e1,e2,e3,r),appopr s1) 453 | end 454 | and app1((e1,_),(e2,_)) = 455 | let val r = Region.plus "app1" (reg_exp e1) (reg_exp e2) 456 | in (App1E(e1,e2,r),valuespec) 457 | end 458 | and app2((e1,_),(e2,_),(e3,_)) = 459 | let val r1 = reg_exp e1 460 | val r2 = reg_exp e2 461 | val r3 = reg_exp e3 462 | val r = if r2 = botreg then 463 | if r3 = botreg then r1 464 | else Region.plus "app2.1" r1 r3 465 | else if r3 = botreg then Region.plus "app2.2" r2 r1 466 | else Region.plus "app2" r2 r3 467 | in (App2E(e1,e2,e3,r),valuespec) 468 | end 469 | and res0 r gs = 470 | case gs of 471 | [] => raise Fail "res0: empty Unres node" 472 | | [g] => g 473 | | [g1,g2] => 474 | (case resFun gs of 475 | SOME [g] => g 476 | | SOME [g1,g2] => if isFun g2 then 477 | let val r = Region.plus "atop" (reg_g g2) (reg_g g1) 478 | fun lam c g = (LambE(c,#1(app1(g2,g)),r), [c]) 479 | val g_m = if isFun1 g1 then SOME(lam Class.fun1 (app1(g1,omega_g))) 480 | else NONE 481 | val g_d = if isFun2 g1 then SOME(lam Class.fun2 (app2(g1,alpha_g,omega_g))) 482 | else NONE 483 | in case (g_m, g_d) of 484 | (SOME (e_m,s_m), SOME (e_d,s_d)) => (GenericE(fn MONADIC => e_m | DYADIC => e_d, r), s_m @ s_d) 485 | | (SOME g,NONE) => g 486 | | (NONE, SOME g) => g 487 | | (NONE, NONE) => resolveErr r "res0.impossible - g1 should be a function" 488 | end 489 | else resolveErr (reg_g g2) "expecting a function" 490 | | SOME _ => resolveErr r "res0.impossible" 491 | | NONE => if isFun1 g2 andalso isVal g1 then res0 r [app1(g2,g1)] 492 | (*else if isOpr1 g1 andalso isFun g2 then res0 r [appOpr1(g1,g2)]*) 493 | else resolveErr (Region.plus "res0.1" (reg_g g2) (reg_g g1)) "could not resolve Unres node") 494 | | g1::g2::g3::gs => 495 | let fun cont() = 496 | if isFun1 g2 then res0 r (app1(g2,g1)::g3::gs) (* ... b f1 a ==> ... b f1(a) *) 497 | else if isOpr1 g2 then 498 | case resFun (g3::gs) of 499 | SOME (g3::gs) => res0 r (g1::appOpr1(g2,g3)::gs) 500 | | SOME nil => raise Fail "res0: impossible" 501 | | NONE => res0 r (g1::appOpr1(g2,g3)::gs) (* pass value as argument to monadic operator! *) 502 | else 503 | resolveErr (Region.plus "res0.2" (reg_g g3) (reg_g g1)) 504 | ("dyadic operator not yet supported for e2: " ^ pr_g g2 ^ "; e1: " ^ pr_g g1) 505 | in case resFun (g1::g2::g3::gs) of 506 | SOME (g1::g2::g3::gs) => (* it is a train *) 507 | (case resFun (g2::g3::gs) of 508 | SOME nil => resolveErr (reg_g g3) "train.impossible1" 509 | | SOME [_] => resolveErr (reg_g g3) "train.impossible2" 510 | | SOME (g2::g3::gs) => 511 | if isFun2 g2 then 512 | case try3Train g1 g2 g3 gs of 513 | (SOME (e_m,s_m), SOME (e_d,s_d), r) => (GenericE(fn MONADIC => e_m | DYADIC => e_d, r), s_m @ s_d) 514 | | (NONE, SOME g_d, _) => g_d 515 | | (SOME g_m, NONE, _) => g_m 516 | | (NONE, NONE, r) => resolveErr r ("expecting f and h in an fgh-train both to be either monadic or dyadic; got " ^ pr_g g3 ^ " and " ^ pr_g g1) 517 | else resolveErr (reg_g g2) ("expecting dyadic function in train but got: " ^ pr_g g2) 518 | | NONE => resolveErr (reg_g g2) ("expecting function in train but got: " ^ pr_g g2)) 519 | | _ => (* it is not a train *) 520 | if isOpr2 g3 then (* ... o2 f a *) 521 | case resFun gs of 522 | SOME(g4::gs) => res0 r (g1::appOpr2(g3,g4,g2)::gs) 523 | | _ => case gs of 524 | g4::gs => res0 r (g1::appOpr2(g3,g4,g2)::gs) 525 | | nil => raise Fail "res0: expecting argument to dyadic operator" 526 | (* 527 | else if isOpr1 g3 andalso List.null gs then 528 | res0 r (g1::appOpr1(g3,g2)::gs) 529 | *) 530 | else if isFun2 g2 andalso isVal g1 andalso isVal g3 then 531 | res0 r (app2(g2,g3,g1)::gs) (* ... b f2 a ==> ... f2(a,b) *) 532 | else if isOpr2 g2 then 533 | if not(isOpr g1) then 534 | case resFun (g3::gs) of 535 | SOME (g3::gs) => res0 r (appOpr2(g2,g3,g1)::gs) 536 | | SOME nil => raise Fail "res0: impossible2" 537 | | NONE => if isVal g3 then res0 r (appOpr2(g2,g3,g1)::gs) 538 | else resolveErr (reg_g g3) ("expecting value or function as left argument to dyadic operator - got " ^ pr_g g3) 539 | else resolveErr (reg_g g1) ("operators cannot take operators as arguments - got " ^ pr_g g1) 540 | else cont() 541 | end 542 | and trainWrap f c r gs = 543 | let val g = (LambE(c,#1(f()),r), [c]) 544 | in SOME(res0 r (g::gs)) 545 | end handle _ => NONE 546 | and try3Train g1 g2 g3 gs = 547 | let val r21 = Region.plus "train2" (reg_g g2) (reg_g g1) 548 | in case resFun (g3::gs) of 549 | SOME nil => resolveErr (reg_g g3) "try3Train.impossible" 550 | | SOME (g3::gs) => 551 | let val r = Region.plus "train1" (reg_g g3) r21 552 | val g_m = if isFun1 g1 andalso isFun1 g3 then (* monadic fgh-train *) 553 | trainWrap (fn () => app2(g2,app1(g3,omega_g),app1(g1,omega_g))) Class.fun1 r gs 554 | else NONE 555 | val g_d = if isFun2 g1 andalso isFun2 g3 then 556 | trainWrap (fn () => app2(g2,app2(g3,alpha_g,omega_g),app2(g1,alpha_g,omega_g))) Class.fun2 r gs 557 | else NONE 558 | in (g_m, g_d, r) 559 | end 560 | | NONE => 561 | let val r = Region.plus "train1" (reg_g g3) r21 562 | val g_m = if isFun1 g1 andalso isVal g3 then (* monadic Agh-train *) 563 | trainWrap (fn () => app2(g2,g3,app1(g1,omega_g))) Class.fun1 r gs 564 | else NONE 565 | val g_d = if isFun2 g1 andalso isVal g3 then (* dyadic Agh-train *) 566 | trainWrap (fn () => app2(g2,g3,app2(g1,alpha_g,omega_g))) Class.fun2 r gs 567 | else if isFun2 g1 andalso List.null gs andalso isOpr1 g3 then (* dyadic fgh-train with / to the left, e.g. *) 568 | trainWrap (fn () => app2(g2,app1(appOpr1(g3,alpha_g),omega_g),app2(g1,alpha_g,omega_g))) Class.fun2 r gs 569 | else NONE 570 | in (g_m, g_d, r) 571 | end 572 | end 573 | and resFun gs = 574 | case gs of 575 | [] => raise Fail "resFun: impossible" 576 | | [g] => if isFun g then SOME gs else 577 | if isOpr1 g then SOME [(LambE(Class.fun2,#1(app1(appOpr1(g,alpha_g),omega_g)),reg_g g), [Class.fun2])] else 578 | NONE 579 | | g1::g2::gs' => 580 | if isOpr2 g2 then NONE (*raise Fail "resFun: dyadic operators not yet supported"*) 581 | else if isFun g1 then SOME gs 582 | else if isOpr1 g1 then 583 | (case resFun (g2::gs') of 584 | SOME(g2::gs') => SOME(appOpr1(g1,g2)::gs') 585 | | SOME nil => raise Fail "resFun: impossible" 586 | | NONE => if isVal g2 then (* convert g1 to a fun2 function *) 587 | let val c = Class.fun2 588 | val r = reg_g g1 589 | val g = app1(appOpr1(g1,alpha_g),omega_g) 590 | val g1' = (LambE(c,#1 g,r), [c]) 591 | in SOME (g1'::g2::gs') 592 | end 593 | else NONE) 594 | else NONE 595 | 596 | val env0 = 597 | let open Class 598 | open L 599 | in List.map (fn (t,l) => (Symb t,l)) 600 | [(Zilde, valuespec), 601 | (Rho, [fun1,fun2]), 602 | (Rtack, [fun1,fun2]), 603 | (Ltack, [fun2]), 604 | (Max, [fun1,fun2]), 605 | (Min, [fun1,fun2]), 606 | (Iota, [fun1]), 607 | (Tilde, [fun1]), 608 | (TildeDia, [opr1fun1,opr1fun2]), 609 | (Trans, [fun1,fun2]), 610 | (Enclose, [fun1]), 611 | (Disclose, [fun1,fun2]), 612 | (Gradeup, [fun1]), 613 | (Gradedown, [fun1]), 614 | (Add, [fun1,fun2]), 615 | (Sub, [fun1,fun2]), 616 | (Times, [fun1,fun2]), 617 | (Div, [fun1,fun2]), 618 | (Cat, [fun1,fun2]), 619 | (Rot, [fun1,fun2]), 620 | (Vrot, [fun1,fun2]), 621 | (Cat, [fun1,fun2]), 622 | (Pipe, [fun1,fun2]), 623 | (In, [fun1,fun2]), 624 | (Qmark, [fun1,fun2]), 625 | (Fac, [fun1,fun2]), 626 | (Circstar, [fun1,fun2]), 627 | (Pow, [fun1,fun2]), 628 | (Vcat, [fun2]), 629 | (Lt, [fun2]), 630 | (Gt, [fun2]), 631 | (Lteq, [fun2]), 632 | (Gteq, [fun2]), 633 | (Eq, [fun2]), 634 | (Neq, [fun2]), 635 | (Take, [fun2]), 636 | (Drop, [fun2]), 637 | (Or, [fun2]), 638 | (And, [fun2]), 639 | (Nor, [fun2]), 640 | (Nand, [fun2]), 641 | (Match, [fun2]), 642 | (Nmatch, [fun1,fun2]), 643 | (Intersect, [fun2]), 644 | (Union, [fun2]), 645 | (Ring, [fun1,fun2,opr2fun1,opr2fun2]), (* fun1,fun2: hack to resolve Ring Dot (outer product) as an application of a dyadic operator *) 646 | (Each, [opr1fun1,opr1fun2]), 647 | (StarDia, [opr2fun1]), 648 | (Circ, [fun1,fun2]), 649 | (Slash, [opr1fun1]), 650 | (Slashbar, [opr1fun1]), 651 | (Backslash, [opr1fun1]), 652 | (Squad, [fun1]), 653 | (Thorn, [fun1,fun2]), 654 | (Dot, [opr2fun2]) (* MEMO: back to opr2fun2 *) 655 | ] 656 | end 657 | 658 | exception ParseErr of Region.loc * string 659 | fun parse E ts = 660 | case parse0 ts of 661 | OK e => 662 | let val () = debug (fn () => "AST is\n " ^ pr_exp e ^ "\n") 663 | val (e',E',_) = resolve E e 664 | in (e',E') 665 | end 666 | | NO (l,f) => raise ParseErr (l,f()) 667 | 668 | open Class 669 | fun add (id,l) e = (Var id, l) :: e 670 | end 671 | -------------------------------------------------------------------------------- /MIT_LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2012 Martin Elsman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MLCOMP ?= mlton -mlb-path-map $(HOME)/.mlton/mlb-path-map 2 | FILES=aplparse.mlb REGION.sig Region.sml AplLex.sml AplParse.sml ParseComb.sml PARSE_COMB.sig test.sml test.mlb 3 | 4 | .PHONY: all 5 | all: $(FILES) Makefile 6 | $(MLCOMP) -output aplparse aplparse.mlb 7 | 8 | test: $(FILES) test.mlb test.sml Makefile 9 | $(MLCOMP) -output test test.mlb 10 | 11 | TESTFILES=test.apl test1.apl test2.apl test3.apl test4.apl test5.apl \ 12 | sierpinski.apl mult.apl primes.apl prelude.apl quadassign.apl \ 13 | boolean.apl math.apl vec.apl chars.apl circ.apl quadids.apl \ 14 | idx.apl underscore.apl thorn.apl train.apl trainatop.apl idx2.apl float.apl complex.apl 15 | .PHONY: tests 16 | tests: test Makefile 17 | @$(foreach tf,$(TESTFILES), echo "\n[Processing $(tf)]"; ./test tests/$(tf);) 18 | 19 | .PHONY: clean 20 | clean: 21 | rm -rf *~ MLB aplparse run test tests/*~ 22 | -------------------------------------------------------------------------------- /PARSE_COMB.sig: -------------------------------------------------------------------------------- 1 | (** Simple parser combinator library that keeps track of position information. *) 2 | signature PARSE_COMB = sig 3 | type token 4 | datatype ('a,'b) either = OK of 'a | NO of 'b 5 | type locerr = Region.loc * (unit -> string) 6 | type 'a p = (token*Region.reg)list -> ('a * Region.reg * (token*Region.reg)list, locerr) either 7 | 8 | val >>> : 'a p * 'b p -> ('a*'b)p 9 | val ->> : unit p * 'b p -> 'b p 10 | val >>- : 'a p * unit p -> 'a p 11 | val ?? : 'a p * 'b p -> ('a*'b -> 'a) -> 'a p 12 | val ??? : 'a p * 'b p -> ('a*'b*Region.reg -> 'a) -> 'a p 13 | val || : 'a p * 'a p -> 'a p 14 | val oo : 'a p * ('a -> 'b) -> 'b p 15 | val ign : 'a p -> unit p 16 | val eat : token -> unit p 17 | val oor : 'a p * ('a*Region.reg -> 'b) -> 'b p 18 | end 19 | 20 | (** 21 | [token] type of tokens. 22 | 23 | ['a p] type of parsers that parse values of type 'a. 24 | 25 | a >>> b 26 | Sequence parsers a and b 27 | 28 | a ->> b 29 | Sequence parsers a and b, discard result of a 30 | 31 | a >>- b 32 | Sequence parsers a and b, discard result of b 33 | 34 | (a ?? b) f 35 | parse a and maybe continue with b, if both succeeds, combine with f 36 | 37 | (a ??? b) f 38 | same as ??, but giving region information to f 39 | 40 | a || b 41 | alternatives 42 | 43 | p oo f 44 | fmap f p 45 | 46 | ign p 47 | discard the result of a parser p 48 | 49 | eat t ts 50 | "eat" one token t from list ts 51 | 52 | p oor f 53 | fmap f p, giving region info to f 54 | *) 55 | -------------------------------------------------------------------------------- /ParseComb.sml: -------------------------------------------------------------------------------- 1 | functor ParseComb(eqtype token 2 | val pr_token : token -> string) : PARSE_COMB = struct 3 | type loc = Region.loc 4 | type reg = Region.reg 5 | 6 | type token = token 7 | 8 | (* keep track of the max location - the longest parse *) 9 | datatype ('a,'b) either = OK of 'a | NO of 'b 10 | 11 | type locerr = loc * (unit -> string) 12 | fun maxLocerr (l1:locerr) l2 = 13 | if Region.lt (#1 l1) (#1 l2) then l2 14 | else l1 15 | 16 | type 'a p = (token*reg)list -> ('a * reg * (token*reg)list, locerr) either 17 | 18 | infix >>> ->> >>- ?? ??? || oo oor 19 | fun p1 >>> p2 = fn ts => 20 | case p1 ts of 21 | OK(v1,r1,ts) => 22 | (case p2 ts of 23 | OK(v2,r2,ts) => OK((v1,v2), Region.plus ">>>" r1 r2, ts) 24 | | NO l => NO (maxLocerr l (#2 r1,fn()=>""))) 25 | | NO l => NO l 26 | 27 | fun p1 ->> p2 = fn ts => 28 | case p1 ts of 29 | OK((),r1,ts) => 30 | (case p2 ts of 31 | OK(v2,r2,ts) => OK(v2, Region.plus "->>" r1 r2, ts) 32 | | NO l => NO (maxLocerr l (#2 r1,fn()=>""))) 33 | | NO l => NO l 34 | 35 | fun p1 >>- p2 = fn ts => 36 | case p1 ts of 37 | OK(v,r1,ts) => 38 | (case p2 ts of 39 | OK((),r2,ts) => OK(v, Region.plus ">>-" r1 r2, ts) 40 | | NO l => NO (maxLocerr l (#2 r1,fn()=>""))) 41 | | NO l => NO l 42 | 43 | fun p1 ?? p2 = fn f => fn ts => 44 | case p1 ts of 45 | OK(v1,r1,ts) => 46 | (case p2 ts of 47 | OK(v2,r2,ts) => OK(f(v1,v2), Region.plus "??" r1 r2, ts) 48 | | _ => OK(v1,r1,ts)) 49 | | NO l => NO l 50 | 51 | fun p1 ??? p2 = fn f => fn ts => 52 | case p1 ts of 53 | OK(v1,r1,ts) => 54 | (case p2 ts of 55 | OK(v2,r2,ts) => 56 | let val r = Region.plus "???" r1 r2 57 | in OK(f(v1,v2,r), r, ts) 58 | end 59 | | NO l => OK(v1,r1,ts)) 60 | | NO l => NO l 61 | 62 | fun p1 || p2 = fn ts => 63 | case p1 ts of 64 | OK(v,r,ts) => OK(v,r,ts) 65 | | NO l1 => case p2 ts of 66 | OK(v,r,ts) => OK(v,r,ts) 67 | | NO l2 => NO (maxLocerr l1 l2) 68 | 69 | fun ign p ts = 70 | case p ts of 71 | OK (_,r,ts) => OK ((),r,ts) 72 | | NO l => NO l 73 | 74 | fun p oo f = fn ts => 75 | case p ts of 76 | OK(v,r,ts) => OK(f v,r,ts) 77 | | NO l => NO l 78 | 79 | fun p oor f = fn ts => 80 | case p ts of 81 | OK(v,r,ts) => OK(f(v,r),r,ts) 82 | | NO l => NO l 83 | 84 | fun eat t ts = 85 | case ts of 86 | nil => NO (Region.botloc,fn() => ("expecting token " ^ pr_token t ^ 87 | " but reached end-of-file")) 88 | | (t',r:Region.reg)::ts' => if t=t' then OK ((),r,ts') 89 | else NO (#1 r,fn()=> ("expecting token " ^ pr_token t ^ 90 | " but found token " ^ pr_token t')) 91 | end 92 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## aplparse: An APL Parser in Standard ML 2 | 3 | This software implements an APL parser in Standard ML. 4 | 5 | ## Example 6 | 7 | The APL program 8 | 9 | ```apl 10 | diff ← {1↓⍵−¯1⌽⍵} 11 | signal ← {¯50⌈50⌊50×(diff 0,⍵)÷0.01+⍵} 12 | ``` 13 | 14 | compiles into the following abstract syntax tree (pretty printed): 15 | 16 | [Assign(diff,Lam(App2(Drop,1,App2(Sub,Omega,App2(Rot,-1,Omega))))), 17 | Assign(signal,Lam(App2(Max,-50, 18 | App2(Min,50, 19 | App2(Times,50, 20 | App2(Div, 21 | App1(diff,App2(Cat,0,Omega)), 22 | App2(Add,0.01,Omega) 23 | ) 24 | ) 25 | ) 26 | ) 27 | ) 28 | ) 29 | ] 30 | 31 | ## Try it! 32 | 33 | The parser compiles with either [MLton](http://mlton.org) or 34 | [MLKit](http://www.elsman.com/mlkit/). 35 | 36 | For compilation and use, 37 | [Smackage](https://github.com/standardml/smackage) is assumed. Add the 38 | following entry to your `~/.smackage/sources.local` file: 39 | 40 | aplparse git git://github.com/melsman/aplparse.git 41 | 42 | Now write 43 | 44 | $ smackage refresh 45 | $ smackage get aplparse 46 | 47 | The implementation builds on the unicode library available at 48 | [https://github.com/melsman/unicode](https://github.com/melsman/unicode), 49 | but Smackage will arrange for this library to be fetched and installed 50 | automatically. 51 | 52 | Then simply write `smackage make aplparse tests` in your shell. 53 | 54 | To use the MLKit as a compiler, write instead: 55 | 56 | $ smackage make aplparse clean 57 | $ MLCOMP=mlkit smackage make aplparse tests 58 | 59 | ## Limitations 60 | 61 | Todo: improved error handling. Although position information is now 62 | maintained in the parser, not all parser errors are reported with 63 | relevant position information. 64 | 65 | ## License 66 | 67 | This software is published under the [MIT License](MIT_LICENSE.md). -------------------------------------------------------------------------------- /REGION.sig: -------------------------------------------------------------------------------- 1 | signature REGION = sig 2 | type filename = string 3 | type loc = int * int * filename 4 | type reg = loc * loc 5 | 6 | val botloc : loc 7 | val loc0 : filename -> loc (* line 1, char 1 *) 8 | val newline : loc -> loc 9 | val next : loc -> loc 10 | val lt : loc -> loc -> bool 11 | val wf : reg -> bool 12 | val ppLoc : loc -> string 13 | val pp : reg -> string 14 | val plus : string -> reg -> reg -> reg 15 | end 16 | 17 | 18 | (* 19 | 20 | botloc 21 | end of file 22 | 23 | loc0 f 24 | line 1, char 1 of file f 25 | 26 | newline 27 | first char on next line 28 | 29 | next 30 | next char on current line 31 | 32 | lt a b 33 | is location a strictly before location b in the file 34 | 35 | wf r 36 | well formed 37 | 38 | ppLoc 39 | pretty print location 40 | 41 | pp 42 | pretty print region 43 | 44 | plus 45 | merge regions (string only used for error reporting) 46 | 47 | *) 48 | -------------------------------------------------------------------------------- /Region.sml: -------------------------------------------------------------------------------- 1 | structure Region :> REGION = struct 2 | type filename = string 3 | type loc = int * int * filename 4 | type reg = loc * loc 5 | val botloc = (0,0,"") 6 | fun loc0 f = (1,0,f) 7 | fun newline l = 8 | if l = botloc then 9 | raise Fail "Region.newline: botloc is not a real location" 10 | else (#1 l + 1,0,#3 l) 11 | fun next l = 12 | if l = botloc then 13 | raise Fail "Region.next: botloc is not a real location" 14 | else (#1 l, #2 l + 1, #3 l) 15 | 16 | fun lt (l1:loc) (l2:loc) = 17 | if l2 = botloc then false 18 | else l1 = botloc orelse 19 | #1 l1 < #1 l2 orelse (#1 l1 = #1 l2 andalso #2 l1 < #2 l2) 20 | fun wf (r:reg) = 21 | #3 (#1 r) <> #3 (#2 r) orelse 22 | #1 r = #2 r orelse lt (#1 r) (#2 r) 23 | fun ppLoc0 (a,b,_) = Int.toString a ^ "." ^ Int.toString b 24 | fun ppLoc (l:loc) = #3 l ^ ":" ^ ppLoc0 l 25 | fun pp (a,b) = 26 | if a = b then ppLoc a 27 | else if #3 a = #3 b then #3 a ^ ":" ^ ppLoc0 a ^ "-" ^ ppLoc0 b 28 | else ppLoc a ^ "-" ^ ppLoc b 29 | fun plus s r1 r2 = 30 | if wf r1 andalso wf r2 andalso (lt (#2 r1) (#1 r2) orelse #3 (#2 r1) <> #3 (#1 r2)) then 31 | (#1 r1, #2 r2) 32 | else raise Fail ("Region " ^ pp r1 ^ " cannot be merged with region " ^ pp r2 ^ " at " ^ s) 33 | end 34 | -------------------------------------------------------------------------------- /aplparse.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | $(SMACKAGE)/unicode/v1/unicode.mlb 4 | in 5 | REGION.sig 6 | Region.sml 7 | PARSE_COMB.sig 8 | ParseComb.sml 9 | AplLex.sml 10 | AplAst.sml 11 | APL_PARSE.sig 12 | AplParse.sml 13 | end -------------------------------------------------------------------------------- /aplparse.smackspec: -------------------------------------------------------------------------------- 1 | description: An APL parser in Standard ML 2 | maintainer: Martin Elsman 3 | keywords: APL, parsing 4 | license: MIT License 5 | requires: unicode v1 (v1.0.4) 6 | -------------------------------------------------------------------------------- /test.mlb: -------------------------------------------------------------------------------- 1 | local $(SML_LIB)/basis/basis.mlb 2 | aplparse.mlb 3 | in test.sml 4 | end -------------------------------------------------------------------------------- /test.sml: -------------------------------------------------------------------------------- 1 | fun rFile f = 2 | let val is = TextIO.openIn f 3 | val s = TextIO.inputAll is 4 | in TextIO.closeIn is; 5 | s 6 | end 7 | 8 | fun prln s = print(s ^ "\n") 9 | 10 | val f = 11 | case CommandLine.arguments() of 12 | [f] => f 13 | | _ => (prln("Usage: " ^ CommandLine.name() ^ " file.apl"); 14 | OS.Process.exit OS.Process.failure) 15 | 16 | val () = prln("[Reading file " ^ f ^ "...]") 17 | val c = rFile f 18 | 19 | val () = prln("[Lexing...]") 20 | val ts = AplLex.lex f c 21 | val () = prln("[File " ^ f ^ " lexed:]") 22 | val () = prln(" " ^ AplLex.pr_tokens (map #1 ts)) 23 | 24 | val () = prln "[Parsing...]" 25 | 26 | val () = 27 | let val (e,_) = AplParse.parse AplParse.env0 ts 28 | in prln("Success:\n " ^ AplAst.pr_exp e) 29 | ; OS.Process.exit OS.Process.success 30 | end handle AplParse.ParseErr (l,msg) => 31 | (prln ("Parse error at " ^ Region.ppLoc l ^ ":\n " ^ msg); 32 | OS.Process.exit OS.Process.failure) 33 | 34 | -------------------------------------------------------------------------------- /tests/boolean.apl: -------------------------------------------------------------------------------- 1 | 2 | a ← (0 ∧ 1) + (1 ∨ 0) 3 | b ← (1 ⍲ 0) 4 | c ← ~ b 5 | d ← (1 ⍱ 0) 6 | e ← 1 2 ∈ 1 3 4 7 | a + b + c + d + +/ e -------------------------------------------------------------------------------- /tests/chars.apl: -------------------------------------------------------------------------------- 1 | 2 | a ← 'hello world' 3 | 4 | ⎕ ← a 5 | 6 | 0 -------------------------------------------------------------------------------- /tests/circ.apl: -------------------------------------------------------------------------------- 1 | 2 | ⎕ ← 'Pi times 1' 3 | ⎕ ← ○ 1 4 | 5 | ⎕ ← 'Pi times 3' 6 | ⎕ ← ○ 3 7 | 8 | ⎕ ← 'Pi times 3.1' 9 | ⎕ ← ○ 3.1 10 | 11 | ⎕ ← 'Sin 3.14' 12 | ⎕ ← 1 ○ 3.14 13 | 14 | ⎕ ← 'Cos 3.14' 15 | ⎕ ← 2 ○ 3.14 16 | 17 | ⎕ ← 'Tan 3.14' 18 | ⎕ ← 3 ○ 3.14 19 | 20 | ⎕ ← 2 + ○ 3.14 21 | 22 | 0 -------------------------------------------------------------------------------- /tests/complex.apl: -------------------------------------------------------------------------------- 1 | ⍝ Complex values 2 | 3 | a ← 1J3 4 | b ← ¯3J2 5 | c ← ¯3.1J2 6 | d ← ¯3J2.2 7 | e ← ¯.3J.2 8 | f ← ¯.3J¯.2 9 | g ← ¯3j2 10 | 11 | h ← a + b + c + d + e + f + g 12 | 13 | ⍝ One with nested arrays: 14 | ⍝ ⎕←' #'[9>|⊃{⍺+⍵*2}/9⍴⊂¯3×.7j.5-⍉a∘.+0j1×a←(⍳n+1)÷n←98] 15 | 16 | ⍝ Here is one without nested arrays: 17 | ⍝ ⎕←' #'[9>|m∘{⍺+⍵*2}⍣9⊢m←¯3×.7j.5-⍉a∘.+0j1×a←(⍳n+1)÷n←98] 18 | 19 | ⍝ One without nested arrays, but with certain parentheses in place 20 | ⎕←' #'[9>|m∘({⍺+⍵*2}⍣9)⊢(m←¯3×.7j.5-⍉a∘.+0j1×(a←(⍳n+1)÷(n←98)))] 21 | 22 | ⍝ And one that uses trains: 23 | 24 | ⍝ ⎕←' #'[9>|m∘(2*⍨+)⍣9⊢m←¯3×.7j.5-⍉a∘.+0j1×a←(⍳n+1)÷n←98] 25 | 26 | ⍝ Credit to @arcfide for these. See also 27 | ⍝ https://github.com/ngn/apl/blob/master/examples/7-mandelbrot.apl 28 | -------------------------------------------------------------------------------- /tests/float.apl: -------------------------------------------------------------------------------- 1 | a ← .232 2 | b ← 0.232 3 | c ← ¯.232 4 | d ← ¯23.0232 5 | -------------------------------------------------------------------------------- /tests/idx.apl: -------------------------------------------------------------------------------- 1 | 2 | V ← ⍳ 28 3 | A ← 5 7 ⍴ ⍳ 35 4 | A3 ← 5 7 2 ⍴ ⍳ 35 5 | X ← ⍳ 2 6 | Y ← 1 4 2 7 | 8 | V1 ← V[5] 9 | V2 ← V[5 2] 10 | 11 | B ← A[1;] 12 | C ← A[1 1;] 13 | D ← A[1 0;3 2] 14 | E ← A[;X] 15 | F ← A[Y;X] 16 | G ← A[Y;] 17 | H ← A3[;;2 2] 18 | I ← A3[;2 2;] 19 | J ← A3[X;;] 20 | -------------------------------------------------------------------------------- /tests/idx2.apl: -------------------------------------------------------------------------------- 1 | 2 | ⍝ a ← 'abcdefg'[3] 3 | ⍝ b←'abcdefg'[3-1] 4 | ⎕←' #'[9>|m∘({⍺+⍵*2}⍣9)⊢(m←¯3×0.7j.5-⍉a∘.+0j1×(a←(⍳n+1)÷(n←98)))] 5 | ⍝ a ← (1+(n←7)) 6 | ⍝ ⎕←' #'[n+(n←98)] -------------------------------------------------------------------------------- /tests/math.apl: -------------------------------------------------------------------------------- 1 | 2 | a ← ⍟ 1 2 3 | 4 | b ← ○ 2 5 | 6 | c ← (! 23) + (? 3) + +/ 2 ? 3 7 | 8 | d ← a + b + c 9 | 10 | e ← ({ ⍵ + 1 } ○ { ⍵ × 3 }) 4 11 | 12 | f ← ⋆ 4 ⍝ e^4 13 | 14 | g ← 2 + 2 ⋆ 0.5 ⍝ 2 + sqrt(2) -------------------------------------------------------------------------------- /tests/mult.apl: -------------------------------------------------------------------------------- 1 | ⍝ Multiplication table 2 | ⍝ a × b scalar multiplication, "a times b" 3 | ⍝ ∘. is the "outer product" operator 4 | ⍝ A ∘.× B every item in A times every item in B 5 | a ← 3 ∘.× ⍳ 10 6 | b ← (⍳ 10) ∘.× ⍳ 10 -------------------------------------------------------------------------------- /tests/prelude.apl: -------------------------------------------------------------------------------- 1 | dot ← { 2 | WA ← (1↓⍴⍵),⍴⍺ 3 | KA ← (⊃⍴⍴⍺)-1 4 | VA ← ⍳ ⊃ ⍴WA 5 | ZA ← (KA⌽¯1↓VA),¯1↑VA 6 | TA ← ZA⍉WA⍴⍺ ⍝ Replicate, transpose 7 | WB ← (¯1↓⍴⍺),⍴⍵ 8 | KB ← ⊃ ⍴⍴⍺ 9 | VB ← ⍳ ⊃ ⍴WB 10 | ZB0 ← (-KB) ↓ KB ⌽ ⍳(⊃⍴VB) 11 | ZB ← (¯1↓(⍳ KB)),ZB0,KB 12 | TB ← ZB⍉WB⍴⍵ ⍝ Replicate, transpose 13 | ⍺⍺ / TA ⍵⍵ TB ⍝ Compute the result 14 | } 15 | 16 | out ← { 17 | A ← ⍺ 18 | B ← ⍵ 19 | X ← ((⍴⍴B)⌽⍳(⍴⍴B)+⍴⍴A) ⍉ ((⍴B),(⍴A)) ⍴ A 20 | Y ← ((⍴A),(⍴B)) ⍴ B 21 | X ⍺⍺ Y 22 | } -------------------------------------------------------------------------------- /tests/primes.apl: -------------------------------------------------------------------------------- 1 | A←2↓⍳100 2 | (1=+⌿0=A∘.|A)/A 3 | -------------------------------------------------------------------------------- /tests/quadassign.apl: -------------------------------------------------------------------------------- 1 | ⎕ ← 1 2 3 2 | 4 -------------------------------------------------------------------------------- /tests/quadids.apl: -------------------------------------------------------------------------------- 1 | 2 | ⎕XXX ← 4 3 | ⎕ML ← 8 4 | 5 | ⎕ML + ⎕XXX -------------------------------------------------------------------------------- /tests/sierpinski.apl: -------------------------------------------------------------------------------- 1 | ⍝ 2 | ⍝ * if S is the triangle of rank n, then rank n+1 would be 3 | ⍝ the two-dimensional catenation: 4 | ⍝ S 0 5 | ⍝ S S 6 | ⍝ where "0" is an all-blank matrix same size as S. 7 | 8 | f ← {(⍵,(⍴⍵)⍴0)⍪⍵,⍵} 9 | ⍝ S ← {' #'[(f⍣⍵) 1 1 ⍴ 1]} 10 | S ← {(f⍣⍵) 1 1 ⍴ 1} 11 | S 5 -------------------------------------------------------------------------------- /tests/test.apl: -------------------------------------------------------------------------------- 1 | diff ← {1↓⍵−¯1⌽⍵} ⍝ Function returning a difference vector 2 | signal ← {¯50⌈50⌊50×(diff 0,⍵)÷0.01+⍵} 3 | 4 | 5 | -------------------------------------------------------------------------------- /tests/test1.apl: -------------------------------------------------------------------------------- 1 | a ← +.× 2 | b ← 3 a 4 3 | 4 | -------------------------------------------------------------------------------- /tests/test2.apl: -------------------------------------------------------------------------------- 1 | v1 ← 2 2 ⍴ ⍳ 4 2 | v2 ← 2 2 ⍴ ⍳ 4 3 | a ← v1 +.× v2 ⍝ inner product 4 | -------------------------------------------------------------------------------- /tests/test3.apl: -------------------------------------------------------------------------------- 1 | m ← 2 2 ⍴ 1 + ⍳ 4 2 | a ← +.× 3 | b ← (2 2 ⍴ ⍳ 4) a m 4 | c ← (2 2 ⍴ ⍳ 4) +.× 2 2 ⍴ ⍳ 4 5 | a1 ← { ⍵ +.× ⍺ } 6 | b1 ← (2 2 ⍴ ⍳ 4) a m 7 | x ← { ⍺ ⍵⍵ . ⍺⍺ ⍵ } 8 | c1 ← (2 2 ⍴ ⍳ 4) +x× 2 2 ⍴ 2 + ⍳ 4 9 | -------------------------------------------------------------------------------- /tests/test4.apl: -------------------------------------------------------------------------------- 1 | f ← { a ← 5 2 | b ← 2 2 ⍴ ⍳ 4 3 | a + b + ⍵ } 4 | f 8 + f 9 5 | -------------------------------------------------------------------------------- /tests/test5.apl: -------------------------------------------------------------------------------- 1 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 2 | ⍝⍝⍝ A one-line function 3 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 4 | f ← { a ← 5 ⋄ b ← 2 2 ⍴ ⍳ 4 ⋄ a + b + ⍵ } ⍝ This is a one-liner 5 | 6 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 7 | ⍝⍝⍝ A multi-line function 8 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 9 | g ← { ⍝ this is a multi-line function 10 | a ← 5 ⍝ This is a comment 11 | b ← 2 2 ⍴ ⍳ 4 12 | a + b + ⍵ } 13 | 14 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 15 | ⍝⍝⍝ Using the functions 16 | ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ 17 | y ← ×/ +/ 2 2 ⍴ f 8 + g 9 18 | a ← b + (b ← 5) -------------------------------------------------------------------------------- /tests/thorn.apl: -------------------------------------------------------------------------------- 1 | 2 | x ← ('The result is "', ⍕ 34.32) ,'"' 3 | 4 | ⎕ ← x -------------------------------------------------------------------------------- /tests/train.apl: -------------------------------------------------------------------------------- 1 | f ← { ⍵ + 1 } 2 | a ← (-,÷)5 3 | 4 | b ← (+,-,÷)5 5 | 6 | t ← f,÷ 7 | 8 | x ← t 4 9 | 10 | h ← 4 (++-) 2 11 | 12 | minmax ← ⌊/,⌈/ 13 | 14 | mm ← minmax 3 4 2 3 2 10 2 3 1 3 4 15 | 16 | Agh ← (2{⍺/⍵}⍳)3 17 | Agh ← (2/⍳)3 18 | 19 | k ← (⊣ + ⊢) 20 | 21 | (+/a) + (+/b) + (+/x) + h + (+/mm) + (+/t 3) + (2 k 4) -------------------------------------------------------------------------------- /tests/trainatop.apl: -------------------------------------------------------------------------------- 1 | 2 | x ← (-÷)4 ⍝ -> ¯0.25 3 | x ← 8(-÷)4 ⍝ -> ¯2.0 4 | 5 | y ← (--)4 ⍝ -> 4 6 | 7 | A ← 2 3 ⍴ ⍳ 6 8 | z ← (⍉⌽)A ⍝ 2 1 9 | ⍝ 4 3 10 | ⍝ 6 5 -> ⍝ 2 4 6 11 | ⍝ 1 3 5 12 | 13 | ⎕ ← z 14 | x + y -------------------------------------------------------------------------------- /tests/underscore.apl: -------------------------------------------------------------------------------- 1 | 2 | x_Y ← 7 3 | _YM ← 7 4 | 5 | x_Y + 3 + _YM -------------------------------------------------------------------------------- /tests/vec.apl: -------------------------------------------------------------------------------- 1 | 2 | b ← 8 3 | a ← 2 b 3 4 | 5 | ⎕ ← a 6 | 7 | 0 --------------------------------------------------------------------------------