{ Let analyze. analyze } Where \ Note on `block.{binder_group expr} \ \ Let y. 2 \ In \ Let x. 1 \ Do (f y) \ In \ (g y x) \ \ `block.{ \ [ \ [ \ `do.`app.{`var."f" [`var."y"]} \ `let.{`var."x" [] `num.1} \ ] \ [`let.{`var."y" [] `num.2}] \ ] \ `app.{`var."g" [`var."y" `var."x"]} \ } \ \ Note that the abstract form holds binders and binder_groups in reversed \ order relative to the concrete form. \ \ Rationale: It is easy to build up environments by using list folds over \ binder lists when they are held in this order. Let analyze root_path. Let STRING_SET. (SEARCH.SET STRING.compare) In Begin (parsing [] [root_path] STRING_SET.empty) Define parsing analyses stack visited. Match stack | `cons.{path stack} Let file_name. (STRING.append path ".84") In Let file. (OS.file_open file_name) In Let text. (OS.file_read_all file) Do (OS.file_close file) In Let tokens. (scan text) In Let tree. (parse tokens) Let visited. (STRING_SET.insert visited path) In Let imports. (gather_imports tree) In Let analysis. { Let path. path Let imports. imports Let text. text Let tokens. tokens Let tree. tree } Let stack. (LIST.reduce imports stack Func stack path. Match (STRING_SET.search visited path) | `just._ stack | `nothing (path::stack) ;) In Goto (parsing (analysis::analyses) stack visited) | `nil Let ordered_paths. (sort_and_check_dependency_graph analyses) In Let ordered_analyses. (LIST.fold ordered_paths [] Func path ordered_analyses. Let analysis. Let has_matching_path analysis. (STRING.equal analysis.path path) In Match (LIST.filter analyses has_matching_path) | `cons.{analysis _} analysis ; In (analysis::ordered_analyses)) In ordered_analyses ; Where Let sort_and_check_dependency_graph analyses. Let MAP. (SEARCH.MAP STRING.compare Func {key _}. key) In Let G. (GRAPH.G MAP) Let g. (LIST.reduce analyses MAP.empty Func g analysis. (MAP.insert g {analysis.path analysis.imports})) In Let sccs. (G.strongly_connected_components g) In Let ordered_paths. (LIST.fold sccs [] Func scc ordered_paths. If ((LIST.length scc) > 1) (die "There is a circular dependency among the packages.") Match scc | `cons.{path _} (path::ordered_paths) ;) In ordered_paths Let scan text. Let n. (STRING.length text) In Begin (scanning 0 [] `whitespace) Define scanning i tokens state. If (n = i) (LIST.reverse (`eof::tokens)) Match state | `whitespace Let i. (scan_whitespace text i) In Goto (scanning i tokens `token) | `token Let {i token}. (scan_token text i) In Goto (scanning i (token::tokens) `whitespace) ; Let parse tokens. (parse_file_block tokens) Let gather_imports tree. Let SET. (SEARCH.SET STRING.compare) In Let reduce_binder reduce_expr set binder. Match binder | `let.{_ expr} (reduce_expr set expr) | `do.expr (reduce_expr set expr) ; In Define reduce_expr set expr. Let reduce_binder set binder. (reduce_binder reduce_expr set binder) In Match expr | `true set | `false set | `num._ set | `str._ set | `package.path (SET.insert set path) | `prim._ set | `var._ set | `chain.{expr chain} (reduce_expr set expr) | `tuple.exprs (LIST.reduce exprs set reduce_expr) | `module.binders (LIST.reduce binders set reduce_binder) | `block.{binder_groups expr} (LIST.reduce binder_groups (reduce_expr set expr) Func set binders. (LIST.reduce binders set reduce_binder)) | `app.{func args} (LIST.reduce (func::args) set reduce_expr) | `func.{self params expr} (reduce_expr set expr) | `goto.expr (reduce_expr set expr) | `switch.{expr clauses} (LIST.reduce clauses (reduce_expr set expr) Func set {_ body}. (reduce_expr set body)) | `cond.clauses (LIST.reduce clauses set Func set {test body}. (reduce_expr (reduce_expr set test) body)) | `if.{test_expr then_expr else_expr} (reduce_expr (reduce_expr (reduce_expr set test_expr) then_expr) else_expr) | `not.expr (reduce_expr set expr) | `and.{test_expr then_expr} (reduce_expr (reduce_expr set test_expr) then_expr) | `or.{test_expr else_expr} (reduce_expr (reduce_expr set test_expr) else_expr) | `list.exprs (LIST.reduce exprs set reduce_expr) | `labeled.{_ expr} (reduce_expr set expr) | `match.{expr clauses} (LIST.reduce clauses (reduce_expr set expr) Func set clause. (reduce_expr set clause.1)) ; In (SET.list (reduce_expr SET.empty tree)) Where Let scan_token text i. Let scan. Switch (STRING.fetch text i) | '\'' scan_char | '"' scan_string | c If (ASCII.is_letter c) scan_word If (ASCII.is_digit c) scan_number scan_basic_symbol ; In (scan text i) Let parse_file_block tokens. Let {expr tokens}. (parse_expr tokens) In Begin (parsing [] tokens) Define parsing binder_groups tokens. Let {token tokens}. (pop_token tokens) In Match token | `eof `block.{(LIST.reverse binder_groups) expr} | `sym.text Cond | (STRING.equal text "Where") Let {group tokens}. (parse_binder_group parse_block_body parse_expr tokens) In Goto (parsing (group::binder_groups) tokens) | True (die "Malformed file block.") ; ; Where Let scan_whitespace text i. Let n. (STRING.length text) In Define chomp_line i. If (i = n) i If ((STRING.fetch text i) = '\n') (i + 1) Goto (chomp_line $ i + 1) In Begin (scanning i) Define scanning i. If (i = n) i Switch (STRING.fetch text i) | ' ' Goto (scanning $ i + 1) | '\n' Goto (scanning $ i + 1) | '\\' Goto (scanning $ chomp_line i) | _ i ; Let scan_char text i. If Not ((STRING.fetch text i) = '\'') (die "Expected quotation mark to begin character literal.") Block Let i. (i + 1) In Let {c i}. Switch (STRING.fetch text i) | '\\' Let i. (i + 1) In Switch (STRING.fetch text i) | '\\' {'\\' i} | 'n' {'\n' i} | '\'' {'\'' i} | _ (die "Invalid character escape sequence.") ; | '\'' (die "Empty character literal.") | '\n' (die "Character literal contains newline character.") | c {c i} ; In If Not ((STRING.fetch text $ i + 1) = '\'') (die "Expected quotation mark to end character literal.") {(i + 2) `num.c} Let scan_string text i. Let begin. i In If Not ((STRING.fetch text i) = '"') (die "Expected quotation mark to begin string literal.") Begin (scanning $ i + 1) Define scanning i. Switch (STRING.fetch text i) | '"' Let end. (i + 1) In Let token. `str.(STRING.clip text begin end) In {end token} | '\\' Let j. (i + 1) Let k. (i + 2) In Switch (STRING.fetch text j) | '\\' Goto (scanning k) | 'n' Goto (scanning k) | '"' Goto (scanning k) | _ (die "Invalid character escape sequence.") ; | '\n' (die "String literal contains newline.") | _ Goto (scanning $ i + 1) ; Let scan_number text i. Begin (scanning i 0) Define scanning i num. Let c. (STRING.fetch text i) In If Not (ASCII.is_digit c) {i `num.num} Goto (scanning (i + 1) $ 10 * num + c + -'0') Let scan_word text i. Let begin. i In Begin (scanning i False False) Define scanning i seen_upper seen_lower. Let c. (STRING.fetch text i) In Switch c | '_' Goto (scanning (i + 1) seen_upper seen_lower) | '\'' Goto (scanning (i + 1) seen_upper seen_lower) | _ If (ASCII.is_digit c) Goto (scanning (i + 1) seen_upper seen_lower) If (ASCII.is_letter c) Goto (scanning (i + 1) Or seen_upper (ASCII.is_upper c) Or seen_lower (ASCII.is_lower c)) If And seen_upper seen_lower {i `sym.(STRING.clip text begin i)} {i `id.(STRING.clip text begin i)} ; Let scan_basic_symbol text i. {(i + 1) `sym.(STRING.clip text i $ i + 1)} Define parse_expr tokens. Let {token tokens}. (pop_token tokens) In Match token | `num.n {`num.n tokens} | `str.s {`str.s tokens} | `id.text Let {chain tokens}. (parse_chain tokens) In Match chain | `nil {`var.text tokens} | `cons._ {`chain.{`var.text chain} tokens} ; | `sym.text Cond | (STRING.equal text "-") Let {expr tokens}. (parse_expr tokens) In {`app.{`prim."negate" [expr]} tokens} | (STRING.equal text "&") Let {expr tokens}. (parse_expr tokens) In {`app.{`prim."ref_new" [expr]} tokens} | (STRING.equal text "?") Let {expr tokens}. (parse_expr tokens) In {`app.{`prim."ref_fetch" [expr]} tokens} | (STRING.equal text "(") (parse_applications parse_expr tokens) | (STRING.equal text "{") Let {token tokens}. (pop_token tokens) In Cond | Or (is_symbol token "Let") (is_symbol token "Define") Let {binders tokens}. (parse_binder_group parse_block_body parse_expr (token::tokens)) In Let {token tokens}. (pop_token tokens) In If (is_symbol token "}") {`module.binders tokens} (die "Malformed module expression.") | True Begin (parsing [] (token::tokens)) Define parsing exprs tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "}") {`tuple.(LIST.reverse exprs) tokens} | True Let {expr tokens}. (parse_expr (token::tokens)) In Goto (parsing (expr::exprs) tokens) ; ; | (STRING.equal text "[") Begin (parsing [] tokens) Define parsing exprs tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "]") {`list.(LIST.reverse exprs) tokens} | True Let {expr tokens}. (parse_expr (token::tokens)) In Goto (parsing (expr::exprs) tokens) ; | (STRING.equal text "`") Let {label tokens}. (parse_id tokens) In Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token ".") Let {expr tokens}. (parse_expr tokens) In {`labeled.{label expr} tokens} | True {`labeled.{label `tuple.[]} (token::tokens)} ; | (STRING.equal text "Prim") Let {text tokens}. (parse_id tokens) In {`prim.text tokens} | (STRING.equal text "Package") Let {token tokens}. (pop_token tokens) In Match token | `str.text {`package.(strip_quotes text) tokens} ; | (STRING.equal text "Goto") Let {expr tokens}. (parse_expr tokens) In Match expr | `app._ {`goto.expr tokens} | _ (die "Goto expression is not an application.") ; | (STRING.equal text "Cond") Let {clauses tokens}. Begin (parsing [] tokens) Define parsing clauses tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token ";") {(LIST.reverse clauses) tokens} | (is_symbol token "|") Let {test tokens}. (parse_expr tokens) In Let {body tokens}. (parse_block_body parse_expr tokens) In Goto (parsing ({test body}::clauses) tokens) | True (die "Malformed Cond expression.") ; In {`cond.clauses tokens} | (STRING.equal text "If") Let {test_expr tokens}. (parse_expr tokens) In Let {then_expr tokens}. (parse_expr tokens) In Let {else_expr tokens}. (parse_expr tokens) In {`if.{test_expr then_expr else_expr} tokens} | (STRING.equal text "When") Let {test_expr tokens}. (parse_expr tokens) In Let {then_expr tokens}. (parse_block_body parse_expr tokens) In {`if.{test_expr then_expr `tuple.[]} tokens} | (STRING.equal text "True") {`true tokens} | (STRING.equal text "False") {`false tokens} | (STRING.equal text "Not") Let {expr tokens}. (parse_expr tokens) In {`not.expr tokens} | (STRING.equal text "And") Let {test_expr tokens}. (parse_expr tokens) In Let {then_expr tokens}. (parse_expr tokens) In {`and.{test_expr then_expr} tokens} | (STRING.equal text "Or") Let {test_expr tokens}. (parse_expr tokens) In Let {else_expr tokens}. (parse_expr tokens) In {`or.{test_expr else_expr} tokens} | (STRING.equal text "Match") Let {expr tokens}. (parse_expr tokens) In Let {clauses tokens}. Begin (parsing [] tokens) Define parsing clauses tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token ";") \ Complain if there is an _ pattern in a clause \ before the last clause. Do Match clauses | `nil {} | `cons.{_ clauses} (LIST.for_each clauses Func {pat _}. Match pat | `default (die "Malformed Match expression.") | _ {} ;) ; In {(LIST.reverse clauses) tokens} | (is_symbol token "|") Let {pat tokens}. (parse_match_pattern tokens) In Let {body tokens}. (parse_block_body parse_expr tokens) In Goto (parsing ({pat body}::clauses) tokens) | True (die "Malformed Match expression.") ; In {`match.{expr clauses} tokens} | (STRING.equal text "Switch") Let {expr tokens}. (parse_expr tokens) In Let {clauses tokens}. Begin (parsing [] tokens) Define parsing clauses tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token ";") \ Complain if there is a catch-all pattern in a \ clause before the last clause. Do Match clauses | `nil {} | `cons.{_ clauses} (LIST.for_each clauses Func {pat _}. Match pat | `default._ (die "Malformed Switch expression.") | _ {} ;) ; In {(LIST.reverse clauses) tokens} | (is_symbol token "|") Let {pat tokens}. (parse_switch_pattern tokens) In Let {body tokens}. (parse_block_body parse_expr tokens) In Goto (parsing ({pat body}::clauses) tokens) | True (die "Malformed Switch expression.") ; In {`switch.{expr clauses} tokens} | (STRING.equal text "Func") Let {param_pats tokens}. (parse_param_patterns tokens) In Let {body tokens}. (parse_block_body parse_expr tokens) In {`func.{`nothing param_pats body} tokens} | (STRING.equal text "Begin") Let {expr tokens}. (parse_expr tokens) In Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "Define") Let {binder tokens}. (parse_define_binder parse_block_body parse_expr tokens) In {`block.{[[binder]] expr} tokens} | True (die "Expected Define form in Begin expression.") ; | (STRING.equal text "Block") (parse_block_body parse_expr tokens) | True (die "No parse.") ; ; Where Define parse_block_body parse_expr tokens. Begin (parsing [] tokens) Define parsing binder_groups tokens. Let {token _}. (pop_token tokens) In Let is_binder_group. Or (is_symbol token "Let") Or (is_symbol token "Do") (is_symbol token "Define") In Cond | is_binder_group Let {group tokens}. (parse_binder_group parse_block_body parse_expr tokens) In Let {token tokens}. (pop_token tokens) In If (is_symbol token "In") Goto (parsing (group::binder_groups) tokens) (die "Malformed block body.") | True Let {expr tokens}. (parse_expr tokens) In {`block.{binder_groups expr} tokens} ; Let parse_switch_pattern tokens. Let {token tokens}. (pop_token tokens) In Match token | `sym.text Cond | (STRING.equal text "_") {`default.`nothing tokens} | (STRING.equal text "-") Let {token tokens}. (pop_token tokens) In Match token | `num.n {`value.-n tokens} | _ (die "Malformed Switch pattern.") ; | True (die "Malformed Switch pattern.") ; | `id.name {`default.`just.name tokens} | `num.n {`value.n tokens} ; Let parse_match_pattern tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "_") {`default tokens} | (is_symbol token "`") Let {label tokens}. (parse_id tokens) In Let {vars tokens}. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token ".") Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "{") Begin (parsing [] tokens) Define parsing vars tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "}") {`tuple.(LIST.reverse vars) tokens} | (is_symbol token "_") Goto (parsing ("_"::vars) tokens) | True Let {var _}. (parse_id (token::tokens)) In Goto (parsing (var::vars) tokens) ; | (is_symbol token "_") {`default tokens} | True Let {name tokens}. (parse_id (token::tokens)) In {`var.name tokens} ; | True {`tuple.[] (token::tokens)} ; In {`labeled.{label vars} tokens} | True (die "Malformed Match pattern.") ; Where Let parse_applications parse_expr tokens. Let combine left_expr right_expr op. If (STRING.equal op.name "apply") Match left_expr | `app.{func args} `app.{func (LIST.append args [right_expr])} | _ `app.{left_expr [right_expr]} ; `app.{`prim.op.name [left_expr right_expr]} In Define parse_completion parse lower_limit left_expr tokens. Let saved_tokens. tokens Let {maybe_op tokens}. (maybe_parse_binary_op tokens) In Match maybe_op | `nothing {left_expr saved_tokens} | `just.op Cond | (op.precedence < lower_limit) {left_expr saved_tokens} | True Let {right_expr tokens}. (parse Match op.associativity | `left (op.precedence + 1) | `right op.precedence ; tokens) In Let expr. (combine left_expr right_expr op) In Goto (parse_completion parse lower_limit expr tokens) ; ; In Define parse lower_limit tokens. Let {expr tokens}. (parse_expr tokens) In Goto (parse_completion parse lower_limit expr tokens) In Let {expr tokens}. (parse 0 tokens) In Let {token tokens}. (pop_token tokens) In If (is_symbol token ")") {expr tokens} (die "Malformed function application expression.") Let parse_chain tokens. Begin (parsing [] tokens) Define parsing chain tokens. Let {token tokens}. (pop_token tokens) In If (is_symbol token ".") Block Let {token tokens}. (pop_token tokens) In Match token | `id._ Goto (parsing (token::chain) tokens) | `num._ Goto (parsing (token::chain) tokens) ; {(LIST.reverse chain) (token::tokens)} Let parse_binder_group parse_block_body parse_expr tokens. Begin (parsing [] tokens) Define parsing binders tokens. Let {token tokens}. (pop_token tokens) In Match token | `sym.text Cond | (STRING.equal text "Do") Let {expr tokens}. (parse_expr tokens) In Let binder. `do.expr In Goto (parsing (binder::binders) tokens) | (STRING.equal text "Define") Let {binder tokens}. (parse_define_binder parse_block_body parse_expr tokens) In Goto (parsing (binder::binders) tokens) | (STRING.equal text "Let") Let {binder tokens}. (parse_let_binder parse_block_body parse_expr tokens) In Goto (parsing (binder::binders) tokens) | True {binders (token::tokens)} ; | _ {binders (token::tokens)} ; Where Let maybe_parse_binary_op tokens. Let {token tokens}. (pop_token tokens) In Let {maybe_spec tokens}. Cond | (is_symbol token ")") {`nothing (token::tokens)} | (is_symbol token "$") {`just.{"apply" 0 `right} tokens} | (is_symbol token "!") {`just.{"ref_store" 1 `right} tokens} | (is_symbol token ":") Let {token tokens}. (pop_token tokens) In If (is_symbol token ":") {`just.{"cons" 2 `right} tokens} (die "Unrecognized binary operator \":\".") | (is_symbol token "=") {`just.{"equal" 3 `left} tokens} | (is_symbol token ">") Let saved_tokens. tokens Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "=") {`just.{"greater_or_equal" 3 `left} tokens} | True {`just.{"greater" 3 `left} saved_tokens} ; | (is_symbol token "<") Let saved_tokens. tokens Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "=") {`just.{"less_or_equal" 3 `left} tokens} | True {`just.{"less" 3 `left} saved_tokens} ; | (is_symbol token "+") {`just.{"add" 4 `left} tokens} | (is_symbol token "*") {`just.{"multiply" 5 `left} tokens} | True {`just.{"apply" 6 `left} (token::tokens)} ; In Match maybe_spec | `nothing {`nothing tokens} | `just.{name precedence associativity} Let maybe_op. `just.{ Let name. name Let precedence. precedence Let associativity. associativity } In {maybe_op tokens} ; Let parse_define_binder parse_block_body parse_expr tokens. Let {var_name tokens}. (parse_id tokens) In Let var_pat. `var.var_name Let {param_pats tokens}. (parse_param_patterns tokens) In Let {body tokens}. (parse_block_body parse_expr tokens) In Let binder. Match param_pats | `nil (die "Malformed Define binder.") | `cons._ Do (LIST.for_each param_pats Func pat. Match pat | `var._ {} | _ (die "Malformed Define binder.") ;) In `let.{var_pat `func.{`just.var_name param_pats body}} ; In {binder tokens} Let parse_let_binder parse_block_body parse_expr tokens. Let {var_pat param_pats tokens}. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "{") Let {var_pat tokens}. (parse_tuple_pattern tokens) In Let {token tokens}. (pop_token tokens) In If (is_symbol token ".") {var_pat [] tokens} (die "Expected . in Let binder.") | True Let {name tokens}. (parse_id (token::tokens)) In Let var_pat. `var.name Let {param_pats tokens}. (parse_param_patterns tokens) In {var_pat param_pats tokens} ; In Let {body tokens}. (parse_block_body parse_expr tokens) In Let binder. Match param_pats | `nil `let.{var_pat body} | `cons._ `let.{var_pat `func.{`nothing param_pats body}} ; In {binder tokens} Where Let parse_param_patterns tokens. Begin (parsing [] tokens) Define parsing pats tokens. Let {token tokens}. (pop_token tokens) In Match token | `id.name Goto (parsing (`var.name::pats) tokens) | `sym.text Cond | (STRING.equal text ".") {(LIST.reverse pats) tokens} | (STRING.equal text "_") Goto (parsing (`ignore::pats) tokens) | (STRING.equal text "{") Let {pat tokens}. (parse_tuple_pattern tokens) In Goto (parsing (pat::pats) tokens) | True (die "Malformed parameter list.") ; ; Where Let parse_tuple_pattern tokens. Begin (parsing [] tokens) Define parsing vars tokens. Let {token tokens}. (pop_token tokens) In Cond | (is_symbol token "}") {`tuple.(LIST.reverse vars) tokens} | (is_symbol token "_") Goto (parsing ("_"::vars) tokens) | True Match token | `id.var Goto (parsing (var::vars) tokens) | _ (die "Malformed tuple pattern.") ; ; Let parse_binder_ids tokens. Begin (parsing_ids [] tokens) Define parsing_ids ids tokens. Let {token tokens}. (pop_token tokens) In Match token | `id.text Goto (parsing_ids (text::ids) tokens) | `sym.text Cond | (STRING.equal text "_") Goto (parsing_ids (text::ids) tokens) | (STRING.equal text ".") {(LIST.reverse ids) tokens} | True (die "Malformed Let binder.") ; ; Let parse_id tokens. Let {token tokens}. (pop_token tokens) In Match token | `id.text {text tokens} | _ (die "Expected identifier.") ; Let parse_sym text tokens. Let {token tokens}. (pop_token tokens) In Match token | `sym.text' If (STRING.equal text' text) tokens (die (STRING.concat ["Expected " text " token but got " text' "."])) | _ (die (STRING.concat ["Token is not " text "."])) ; Where Let pop_token tokens. Match tokens | `cons.pair pair ; Let is_symbol token text. Match token | `sym.text' (STRING.equal text text') | _ False ; Let die. Prim die Let strip_quotes s. (STRING.clip s 1 $ (STRING.length s) + -1) Where Let ASCII. Package "ascii" Let GRAPH. Package "graph" Let LIST. Package "list" Let OS. Package "os" Let SEARCH. Package "search" Let STDIO. Package "stdio" Let STRING. Package "string"